diff options
| -rw-r--r-- | NetWare/CLIBstuf.c | 216 | ||||
| -rw-r--r-- | NetWare/Main.c | 234 | ||||
| -rw-r--r-- | NetWare/NWTInfo.c | 936 | ||||
| -rw-r--r-- | NetWare/NWUtil.c | 1168 | ||||
| -rw-r--r-- | NetWare/Nwmain.c | 2016 | ||||
| -rw-r--r-- | NetWare/Nwpipe.c | 1006 | ||||
| -rw-r--r-- | NetWare/deb.h | 28 | ||||
| -rw-r--r-- | NetWare/intdef.h | 28 | ||||
| -rw-r--r-- | NetWare/interface.c | 122 | ||||
| -rw-r--r-- | NetWare/interface.h | 20 | ||||
| -rw-r--r-- | NetWare/iperlhost.h | 16 | ||||
| -rw-r--r-- | NetWare/netware.h | 12 | ||||
| -rw-r--r-- | NetWare/nw5.c | 894 | ||||
| -rw-r--r-- | NetWare/nw5sck.c | 58 | ||||
| -rw-r--r-- | NetWare/nw5thread.c | 10 | ||||
| -rw-r--r-- | NetWare/nw5thread.h | 88 | ||||
| -rw-r--r-- | NetWare/nwhashcls.h | 32 | ||||
| -rw-r--r-- | NetWare/nwperlhost.h | 262 | ||||
| -rw-r--r-- | NetWare/nwperlsys.c | 194 | ||||
| -rw-r--r-- | NetWare/nwperlsys.h | 326 | ||||
| -rw-r--r-- | NetWare/nwpipe.h | 28 | ||||
| -rw-r--r-- | NetWare/nwplglob.c | 60 | ||||
| -rw-r--r-- | NetWare/nwtinfo.h | 34 | ||||
| -rw-r--r-- | NetWare/nwutil.h | 50 | ||||
| -rw-r--r-- | NetWare/nwvmem.h | 292 | ||||
| -rw-r--r-- | NetWare/win32ish.h | 8 | ||||
| -rw-r--r-- | Porting/timecheck.c | 104 | ||||
| -rw-r--r-- | Porting/timecheck2.c | 4 | ||||
| -rw-r--r-- | amigaos4/amigaio.c | 1862 | ||||
| -rw-r--r-- | amigaos4/amigaio.h | 28 | ||||
| -rw-r--r-- | amigaos4/amigaos.c | 1042 | ||||
| -rw-r--r-- | av.c | 494 | ||||
| -rw-r--r-- | av.h | 2 | ||||
| -rw-r--r-- | cv.h | 48 | ||||
| -rw-r--r-- | cygwin/cygwin.c | 400 | ||||
| -rw-r--r-- | deb.c | 252 | ||||
| -rw-r--r-- | dist/IO/poll.c | 84 | ||||
| -rw-r--r-- | djgpp/djgpp.c | 66 | ||||
| -rw-r--r-- | doio.c | 2406 | ||||
| -rw-r--r-- | doop.c | 750 | ||||
| -rw-r--r-- | dosish.h | 6 | ||||
| -rw-r--r-- | dquote.c | 22 | ||||
| -rw-r--r-- | dump.c | 1854 | ||||
| -rw-r--r-- | ext/DynaLoader/dlutils.c | 30 | ||||
| -rw-r--r-- | ext/File-Glob/bsd_glob.c | 1250 | ||||
| -rw-r--r-- | ext/File-Glob/bsd_glob.h | 36 | ||||
| -rw-r--r-- | ext/SDBM_File/dba.c | 104 | ||||
| -rw-r--r-- | ext/SDBM_File/dbd.c | 142 | ||||
| -rw-r--r-- | ext/SDBM_File/dbe.c | 704 | ||||
| -rw-r--r-- | ext/SDBM_File/dbu.c | 318 | ||||
| -rw-r--r-- | ext/SDBM_File/sdbm.c | 528 | ||||
| -rw-r--r-- | ext/SDBM_File/sdbm.h | 32 | ||||
| -rw-r--r-- | ext/SDBM_File/tune.h | 2 | ||||
| -rw-r--r-- | ext/SDBM_File/util.c | 52 | ||||
| -rw-r--r-- | ext/Win32CORE/Win32CORE.c | 128 | ||||
| -rw-r--r-- | generate_uudmap.c | 22 | ||||
| -rw-r--r-- | gv.c | 2072 | ||||
| -rw-r--r-- | gv.h | 86 | ||||
| -rw-r--r-- | handy.h | 42 | ||||
| -rw-r--r-- | hints/t001.c | 94 | ||||
| -rw-r--r-- | hv.c | 2602 | ||||
| -rw-r--r-- | hv.h | 108 | ||||
| -rw-r--r-- | inline.h | 136 | ||||
| -rw-r--r-- | intrpvar.h | 38 | ||||
| -rw-r--r-- | invlist_inline.h | 10 | ||||
| -rw-r--r-- | iperlsys.h | 502 | ||||
| -rw-r--r-- | locale.c | 88 | ||||
| -rw-r--r-- | malloc.c | 1770 | ||||
| -rw-r--r-- | mathoms.c | 94 | ||||
| -rw-r--r-- | mg.c | 2320 | ||||
| -rw-r--r-- | mg.h | 24 | ||||
| -rw-r--r-- | mro_core.c | 1188 | ||||
| -rw-r--r-- | numeric.c | 220 | ||||
| -rw-r--r-- | op.h | 196 | ||||
| -rw-r--r-- | os2/dl_os2.c | 198 | ||||
| -rw-r--r-- | os2/os2.c | 4972 | ||||
| -rw-r--r-- | os2/os2ish.h | 354 | ||||
| -rw-r--r-- | os2/perlrexx.c | 108 | ||||
| -rw-r--r-- | pad.c | 2200 | ||||
| -rw-r--r-- | pad.h | 88 | ||||
| -rw-r--r-- | parser.h | 10 | ||||
| -rw-r--r-- | patchlevel.h | 86 | ||||
| -rw-r--r-- | perl_inc_macro.h | 40 | ||||
| -rw-r--r-- | perlio.c | 4134 | ||||
| -rw-r--r-- | perlio.h | 12 | ||||
| -rw-r--r-- | perliol.h | 10 | ||||
| -rw-r--r-- | perlvars.h | 14 | ||||
| -rw-r--r-- | perly.c | 98 | ||||
| -rw-r--r-- | plan9/plan9.c | 24 | ||||
| -rw-r--r-- | plan9/plan9ish.h | 2 | ||||
| -rw-r--r-- | pp.h | 88 | ||||
| -rw-r--r-- | pp_ctl.c | 5278 | ||||
| -rw-r--r-- | pp_hot.c | 2524 | ||||
| -rw-r--r-- | pp_pack.c | 3820 | ||||
| -rw-r--r-- | pp_sys.c | 3986 | ||||
| -rw-r--r-- | qnx/qnx.c | 2 | ||||
| -rw-r--r-- | regcomp.c | 5262 | ||||
| -rw-r--r-- | regcomp.h | 34 | ||||
| -rw-r--r-- | regen.pl | 2 | ||||
| -rw-r--r-- | scope.c | 808 | ||||
| -rw-r--r-- | scope.h | 48 | ||||
| -rw-r--r-- | t/lib/h2ph.h | 6 | ||||
| -rw-r--r-- | taint.c | 150 | ||||
| -rw-r--r-- | thread.h | 172 | ||||
| -rw-r--r-- | universal.c | 612 | ||||
| -rw-r--r-- | unixish.h | 4 | ||||
| -rw-r--r-- | utf8.c | 510 | ||||
| -rw-r--r-- | utf8.h | 4 | ||||
| -rw-r--r-- | utfebcdic.h | 122 | ||||
| -rw-r--r-- | util.c | 2548 | ||||
| -rw-r--r-- | util.h | 24 | ||||
| -rw-r--r-- | vms/munchconfig.c | 30 | ||||
| -rw-r--r-- | vms/vms.c | 5178 | ||||
| -rw-r--r-- | vms/vmsish.h | 4 | ||||
| -rw-r--r-- | win32/fcrypt.c | 418 | ||||
| -rw-r--r-- | win32/include/dirent.h | 20 | ||||
| -rw-r--r-- | win32/include/sys/socket.h | 2 | ||||
| -rw-r--r-- | win32/perlglob.c | 22 | ||||
| -rw-r--r-- | win32/perlhost.h | 544 | ||||
| -rw-r--r-- | win32/perllib.c | 176 | ||||
| -rw-r--r-- | win32/vdir.h | 720 | ||||
| -rw-r--r-- | win32/vmem.h | 788 | ||||
| -rw-r--r-- | win32/win32.c | 2370 | ||||
| -rw-r--r-- | win32/win32.h | 10 | ||||
| -rw-r--r-- | win32/win32io.c | 4 | ||||
| -rw-r--r-- | win32/win32iop.h | 2 | ||||
| -rw-r--r-- | win32/win32sck.c | 406 | ||||
| -rw-r--r-- | win32/win32thread.h | 98 |
128 files changed, 40823 insertions, 40823 deletions
diff --git a/NetWare/CLIBstuf.c b/NetWare/CLIBstuf.c index 26a4a4b502..f0e58b14b9 100644 --- a/NetWare/CLIBstuf.c +++ b/NetWare/CLIBstuf.c @@ -33,119 +33,119 @@ void ImportFromCLIB (unsigned int nlmHandle, void** psymbol, char* symbolName) { - *psymbol = ImportSymbol(nlmHandle, symbolName); - if (*psymbol == NULL) - { - ConsolePrintf("Symbol %s not found, unable to continue\n", symbolName); - exit(1); - } + *psymbol = ImportSymbol(nlmHandle, symbolName); + if (*psymbol == NULL) + { + ConsolePrintf("Symbol %s not found, unable to continue\n", symbolName); + exit(1); + } } void fnInitGpfGlobals(void) { - unsigned int nlmHandle = GetNLMHandle(); - - ImportFromCLIB(nlmHandle, &gpf___get_stdin, "__get_stdin"); - ImportFromCLIB(nlmHandle, &gpf___get_stdout, "__get_stdout"); - ImportFromCLIB(nlmHandle, &gpf___get_stderr, "__get_stderr"); - ImportFromCLIB(nlmHandle, &gpf_clearerr, "clearerr"); - ImportFromCLIB(nlmHandle, &gpf_fclose, "fclose"); - ImportFromCLIB(nlmHandle, &gpf_feof, "feof"); - ImportFromCLIB(nlmHandle, &gpf_ferror, "ferror"); - ImportFromCLIB(nlmHandle, &gpf_fflush, "fflush"); - ImportFromCLIB(nlmHandle, &gpf_fgetc, "fgetc"); - ImportFromCLIB(nlmHandle, &gpf_fgetpos, "fgetpos"); - ImportFromCLIB(nlmHandle, &gpf_fgets, "fgets"); - ImportFromCLIB(nlmHandle, &gpf_fopen, "fopen"); - ImportFromCLIB(nlmHandle, &gpf_fputc, "fputc"); - ImportFromCLIB(nlmHandle, &gpf_fputs, "fputs"); - ImportFromCLIB(nlmHandle, &gpf_fread, "fread"); - ImportFromCLIB(nlmHandle, &gpf_freopen, "freopen"); - ImportFromCLIB(nlmHandle, &gpf_fscanf, "fscanf"); - ImportFromCLIB(nlmHandle, &gpf_fseek, "fseek"); - ImportFromCLIB(nlmHandle, &gpf_fsetpos, "fsetpos"); - ImportFromCLIB(nlmHandle, &gpf_ftell, "ftell"); - ImportFromCLIB(nlmHandle, &gpf_fwrite, "fwrite"); - ImportFromCLIB(nlmHandle, &gpf_getc, "getc"); - ImportFromCLIB(nlmHandle, &gpf_getchar, "getchar"); - ImportFromCLIB(nlmHandle, &gpf_gets, "gets"); - ImportFromCLIB(nlmHandle, &gpf_perror, "perror"); - ImportFromCLIB(nlmHandle, &gpf_putc, "putc"); - ImportFromCLIB(nlmHandle, &gpf_putchar, "putchar"); - ImportFromCLIB(nlmHandle, &gpf_puts, "puts"); - ImportFromCLIB(nlmHandle, &gpf_rename, "rename"); - ImportFromCLIB(nlmHandle, &gpf_rewind, "rewind"); - ImportFromCLIB(nlmHandle, &gpf_scanf, "scanf"); - ImportFromCLIB(nlmHandle, &gpf_setbuf, "setbuf"); - ImportFromCLIB(nlmHandle, &gpf_setvbuf, "setvbuf"); - ImportFromCLIB(nlmHandle, &gpf_sscanf, "sscanf"); - ImportFromCLIB(nlmHandle, &gpf_tmpfile, "tmpfile"); - ImportFromCLIB(nlmHandle, &gpf_tmpnam, "tmpnam"); - ImportFromCLIB(nlmHandle, &gpf_ungetc, "ungetc"); - ImportFromCLIB(nlmHandle, &gpf_vfscanf, "vfscanf"); - ImportFromCLIB(nlmHandle, &gpf_vscanf, "vscanf"); - ImportFromCLIB(nlmHandle, &gpf_vsscanf, "vsscanf"); - ImportFromCLIB(nlmHandle, &gpf_fdopen, "fdopen"); - ImportFromCLIB(nlmHandle, &gpf_fileno, "fileno"); - ImportFromCLIB(nlmHandle, &gpf_cgets, "cgets"); - ImportFromCLIB(nlmHandle, &gpf_cprintf, "cprintf"); - ImportFromCLIB(nlmHandle, &gpf_cputs, "cputs"); - ImportFromCLIB(nlmHandle, &gpf_cscanf, "cscanf"); - ImportFromCLIB(nlmHandle, &gpf_fcloseall, "fcloseall"); - ImportFromCLIB(nlmHandle, &gpf_fgetchar, "fgetchar"); - ImportFromCLIB(nlmHandle, &gpf_flushall, "flushall"); - ImportFromCLIB(nlmHandle, &gpf_fputchar, "fputchar"); - ImportFromCLIB(nlmHandle, &gpf_getch, "getch"); - ImportFromCLIB(nlmHandle, &gpf_getche, "getche"); - ImportFromCLIB(nlmHandle, &gpf_putch, "putch"); - ImportFromCLIB(nlmHandle, &gpf_ungetch, "ungetch"); - ImportFromCLIB(nlmHandle, &gpf_vcprintf, "vcprintf"); - ImportFromCLIB(nlmHandle, &gpf_vcscanf, "vcscanf"); - - ImportFromCLIB(nlmHandle, &gpf_memchr, "memchr"); - ImportFromCLIB(nlmHandle, &gpf_memcmp, "memcmp"); - ImportFromCLIB(nlmHandle, &gpf_memcpy, "memcpy"); - ImportFromCLIB(nlmHandle, &gpf_memmove, "memmove"); - ImportFromCLIB(nlmHandle, &gpf_memset, "memset"); - ImportFromCLIB(nlmHandle, &gpf_memicmp, "memicmp"); - - ImportFromCLIB(nlmHandle, &gpf_strerror, "strerror"); - ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); - - ImportFromCLIB(nlmHandle, &gpf_strcpy, "strcpy"); - ImportFromCLIB(nlmHandle, &gpf_strcat, "strcat"); - ImportFromCLIB(nlmHandle, &gpf_strchr, "strchr"); - ImportFromCLIB(nlmHandle, &gpf_strstr, "strstr"); - ImportFromCLIB(nlmHandle, &gpf_strcoll, "strcoll"); - ImportFromCLIB(nlmHandle, &gpf_strcspn, "strcspn"); - ImportFromCLIB(nlmHandle, &gpf_strpbrk, "strpbrk"); - ImportFromCLIB(nlmHandle, &gpf_strrchr, "strrchr"); - ImportFromCLIB(nlmHandle, &gpf_strrev, "strrev"); - ImportFromCLIB(nlmHandle, &gpf_strspn, "strspn"); - ImportFromCLIB(nlmHandle, &gpf_strupr, "strupr"); - ImportFromCLIB(nlmHandle, &gpf_strxfrm, "strxfrm"); - ImportFromCLIB(nlmHandle, &gpf_strcmp, "strcmp"); - ImportFromCLIB(nlmHandle, &gpf_stricmp, "stricmp"); - ImportFromCLIB(nlmHandle, &gpf_strtok, "strtok"); - ImportFromCLIB(nlmHandle, &gpf_strlen, "strlen"); - ImportFromCLIB(nlmHandle, &gpf_strncpy, "strncpy"); - ImportFromCLIB(nlmHandle, &gpf_strncat, "strncat"); - ImportFromCLIB(nlmHandle, &gpf_strncmp, "strncmp"); - ImportFromCLIB(nlmHandle, &gpf_strcmpi, "strcmpi"); - ImportFromCLIB(nlmHandle, &gpf_strnicmp, "strnicmp"); - ImportFromCLIB(nlmHandle, &gpf_strdup, "strdup"); - ImportFromCLIB(nlmHandle, &gpf_strlist, "strlist"); - ImportFromCLIB(nlmHandle, &gpf_strlwr, "strlwr"); - ImportFromCLIB(nlmHandle, &gpf_strnset, "strnset"); - ImportFromCLIB(nlmHandle, &gpf_strset, "strset"); - ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); - ImportFromCLIB(nlmHandle, &gpf_printf, "printf"); - ImportFromCLIB(nlmHandle, &gpf_fprintf, "fprintf"); - ImportFromCLIB(nlmHandle, &gpf_sprintf, "sprintf"); - ImportFromCLIB(nlmHandle, &gpf_vprintf, "vprintf"); - ImportFromCLIB(nlmHandle, &gpf_vfprintf, "vfprintf"); - ImportFromCLIB(nlmHandle, &gpf_vsprintf, "vsprintf"); + unsigned int nlmHandle = GetNLMHandle(); + + ImportFromCLIB(nlmHandle, &gpf___get_stdin, "__get_stdin"); + ImportFromCLIB(nlmHandle, &gpf___get_stdout, "__get_stdout"); + ImportFromCLIB(nlmHandle, &gpf___get_stderr, "__get_stderr"); + ImportFromCLIB(nlmHandle, &gpf_clearerr, "clearerr"); + ImportFromCLIB(nlmHandle, &gpf_fclose, "fclose"); + ImportFromCLIB(nlmHandle, &gpf_feof, "feof"); + ImportFromCLIB(nlmHandle, &gpf_ferror, "ferror"); + ImportFromCLIB(nlmHandle, &gpf_fflush, "fflush"); + ImportFromCLIB(nlmHandle, &gpf_fgetc, "fgetc"); + ImportFromCLIB(nlmHandle, &gpf_fgetpos, "fgetpos"); + ImportFromCLIB(nlmHandle, &gpf_fgets, "fgets"); + ImportFromCLIB(nlmHandle, &gpf_fopen, "fopen"); + ImportFromCLIB(nlmHandle, &gpf_fputc, "fputc"); + ImportFromCLIB(nlmHandle, &gpf_fputs, "fputs"); + ImportFromCLIB(nlmHandle, &gpf_fread, "fread"); + ImportFromCLIB(nlmHandle, &gpf_freopen, "freopen"); + ImportFromCLIB(nlmHandle, &gpf_fscanf, "fscanf"); + ImportFromCLIB(nlmHandle, &gpf_fseek, "fseek"); + ImportFromCLIB(nlmHandle, &gpf_fsetpos, "fsetpos"); + ImportFromCLIB(nlmHandle, &gpf_ftell, "ftell"); + ImportFromCLIB(nlmHandle, &gpf_fwrite, "fwrite"); + ImportFromCLIB(nlmHandle, &gpf_getc, "getc"); + ImportFromCLIB(nlmHandle, &gpf_getchar, "getchar"); + ImportFromCLIB(nlmHandle, &gpf_gets, "gets"); + ImportFromCLIB(nlmHandle, &gpf_perror, "perror"); + ImportFromCLIB(nlmHandle, &gpf_putc, "putc"); + ImportFromCLIB(nlmHandle, &gpf_putchar, "putchar"); + ImportFromCLIB(nlmHandle, &gpf_puts, "puts"); + ImportFromCLIB(nlmHandle, &gpf_rename, "rename"); + ImportFromCLIB(nlmHandle, &gpf_rewind, "rewind"); + ImportFromCLIB(nlmHandle, &gpf_scanf, "scanf"); + ImportFromCLIB(nlmHandle, &gpf_setbuf, "setbuf"); + ImportFromCLIB(nlmHandle, &gpf_setvbuf, "setvbuf"); + ImportFromCLIB(nlmHandle, &gpf_sscanf, "sscanf"); + ImportFromCLIB(nlmHandle, &gpf_tmpfile, "tmpfile"); + ImportFromCLIB(nlmHandle, &gpf_tmpnam, "tmpnam"); + ImportFromCLIB(nlmHandle, &gpf_ungetc, "ungetc"); + ImportFromCLIB(nlmHandle, &gpf_vfscanf, "vfscanf"); + ImportFromCLIB(nlmHandle, &gpf_vscanf, "vscanf"); + ImportFromCLIB(nlmHandle, &gpf_vsscanf, "vsscanf"); + ImportFromCLIB(nlmHandle, &gpf_fdopen, "fdopen"); + ImportFromCLIB(nlmHandle, &gpf_fileno, "fileno"); + ImportFromCLIB(nlmHandle, &gpf_cgets, "cgets"); + ImportFromCLIB(nlmHandle, &gpf_cprintf, "cprintf"); + ImportFromCLIB(nlmHandle, &gpf_cputs, "cputs"); + ImportFromCLIB(nlmHandle, &gpf_cscanf, "cscanf"); + ImportFromCLIB(nlmHandle, &gpf_fcloseall, "fcloseall"); + ImportFromCLIB(nlmHandle, &gpf_fgetchar, "fgetchar"); + ImportFromCLIB(nlmHandle, &gpf_flushall, "flushall"); + ImportFromCLIB(nlmHandle, &gpf_fputchar, "fputchar"); + ImportFromCLIB(nlmHandle, &gpf_getch, "getch"); + ImportFromCLIB(nlmHandle, &gpf_getche, "getche"); + ImportFromCLIB(nlmHandle, &gpf_putch, "putch"); + ImportFromCLIB(nlmHandle, &gpf_ungetch, "ungetch"); + ImportFromCLIB(nlmHandle, &gpf_vcprintf, "vcprintf"); + ImportFromCLIB(nlmHandle, &gpf_vcscanf, "vcscanf"); + + ImportFromCLIB(nlmHandle, &gpf_memchr, "memchr"); + ImportFromCLIB(nlmHandle, &gpf_memcmp, "memcmp"); + ImportFromCLIB(nlmHandle, &gpf_memcpy, "memcpy"); + ImportFromCLIB(nlmHandle, &gpf_memmove, "memmove"); + ImportFromCLIB(nlmHandle, &gpf_memset, "memset"); + ImportFromCLIB(nlmHandle, &gpf_memicmp, "memicmp"); + + ImportFromCLIB(nlmHandle, &gpf_strerror, "strerror"); + ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); + + ImportFromCLIB(nlmHandle, &gpf_strcpy, "strcpy"); + ImportFromCLIB(nlmHandle, &gpf_strcat, "strcat"); + ImportFromCLIB(nlmHandle, &gpf_strchr, "strchr"); + ImportFromCLIB(nlmHandle, &gpf_strstr, "strstr"); + ImportFromCLIB(nlmHandle, &gpf_strcoll, "strcoll"); + ImportFromCLIB(nlmHandle, &gpf_strcspn, "strcspn"); + ImportFromCLIB(nlmHandle, &gpf_strpbrk, "strpbrk"); + ImportFromCLIB(nlmHandle, &gpf_strrchr, "strrchr"); + ImportFromCLIB(nlmHandle, &gpf_strrev, "strrev"); + ImportFromCLIB(nlmHandle, &gpf_strspn, "strspn"); + ImportFromCLIB(nlmHandle, &gpf_strupr, "strupr"); + ImportFromCLIB(nlmHandle, &gpf_strxfrm, "strxfrm"); + ImportFromCLIB(nlmHandle, &gpf_strcmp, "strcmp"); + ImportFromCLIB(nlmHandle, &gpf_stricmp, "stricmp"); + ImportFromCLIB(nlmHandle, &gpf_strtok, "strtok"); + ImportFromCLIB(nlmHandle, &gpf_strlen, "strlen"); + ImportFromCLIB(nlmHandle, &gpf_strncpy, "strncpy"); + ImportFromCLIB(nlmHandle, &gpf_strncat, "strncat"); + ImportFromCLIB(nlmHandle, &gpf_strncmp, "strncmp"); + ImportFromCLIB(nlmHandle, &gpf_strcmpi, "strcmpi"); + ImportFromCLIB(nlmHandle, &gpf_strnicmp, "strnicmp"); + ImportFromCLIB(nlmHandle, &gpf_strdup, "strdup"); + ImportFromCLIB(nlmHandle, &gpf_strlist, "strlist"); + ImportFromCLIB(nlmHandle, &gpf_strlwr, "strlwr"); + ImportFromCLIB(nlmHandle, &gpf_strnset, "strnset"); + ImportFromCLIB(nlmHandle, &gpf_strset, "strset"); + ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); + ImportFromCLIB(nlmHandle, &gpf_printf, "printf"); + ImportFromCLIB(nlmHandle, &gpf_fprintf, "fprintf"); + ImportFromCLIB(nlmHandle, &gpf_sprintf, "sprintf"); + ImportFromCLIB(nlmHandle, &gpf_vprintf, "vprintf"); + ImportFromCLIB(nlmHandle, &gpf_vfprintf, "vfprintf"); + ImportFromCLIB(nlmHandle, &gpf_vsprintf, "vsprintf"); } diff --git a/NetWare/Main.c b/NetWare/Main.c index 5116cbcfe1..4dea1dd2be 100644 --- a/NetWare/Main.c +++ b/NetWare/Main.c @@ -32,8 +32,8 @@ #include "clibstuf.h" #ifdef MPK_ON - #include <mpktypes.h> - #include <mpkapis.h> + #include <mpktypes.h> + #include <mpkapis.h> #endif //MPK_ON @@ -52,131 +52,131 @@ void main(void) { - fnInitGpfGlobals(); // For importing the CLIB calls in place of the Watcom calls - SynchronizeStart(); // Don't allow anything else to happen until all the symbols are imported - #ifdef MPK_ON - ExitThread(TSR_THREAD, 0); - #else - ExitThread(TSR_THREAD, 0); - #endif + fnInitGpfGlobals(); // For importing the CLIB calls in place of the Watcom calls + SynchronizeStart(); // Don't allow anything else to happen until all the symbols are imported + #ifdef MPK_ON + ExitThread(TSR_THREAD, 0); + #else + ExitThread(TSR_THREAD, 0); + #endif } void ImportFromCLIB (unsigned int nlmHandle, void** psymbol, char* symbolName) { - *psymbol = ImportSymbol(nlmHandle, symbolName); - if (*psymbol == NULL) - { - ConsolePrintf("Symbol %s not found, unable to continue\n", symbolName); - exit(1); - } + *psymbol = ImportSymbol(nlmHandle, symbolName); + if (*psymbol == NULL) + { + ConsolePrintf("Symbol %s not found, unable to continue\n", symbolName); + exit(1); + } } void fnInitGpfGlobals(void) { - unsigned int nlmHandle = GetNLMHandle(); - - ImportFromCLIB(nlmHandle, &gpf___get_stdin, "__get_stdin"); - ImportFromCLIB(nlmHandle, &gpf___get_stdout, "__get_stdout"); - ImportFromCLIB(nlmHandle, &gpf___get_stderr, "__get_stderr"); - ImportFromCLIB(nlmHandle, &gpf_clearerr, "clearerr"); - ImportFromCLIB(nlmHandle, &gpf_fclose, "fclose"); - ImportFromCLIB(nlmHandle, &gpf_feof, "feof"); - ImportFromCLIB(nlmHandle, &gpf_ferror, "ferror"); - ImportFromCLIB(nlmHandle, &gpf_fflush, "fflush"); - ImportFromCLIB(nlmHandle, &gpf_fgetc, "fgetc"); - ImportFromCLIB(nlmHandle, &gpf_fgetpos, "fgetpos"); - ImportFromCLIB(nlmHandle, &gpf_fgets, "fgets"); - ImportFromCLIB(nlmHandle, &gpf_fopen, "fopen"); - ImportFromCLIB(nlmHandle, &gpf_fputc, "fputc"); - ImportFromCLIB(nlmHandle, &gpf_fputs, "fputs"); - ImportFromCLIB(nlmHandle, &gpf_fread, "fread"); - ImportFromCLIB(nlmHandle, &gpf_freopen, "freopen"); - ImportFromCLIB(nlmHandle, &gpf_fscanf, "fscanf"); - ImportFromCLIB(nlmHandle, &gpf_fseek, "fseek"); - ImportFromCLIB(nlmHandle, &gpf_fsetpos, "fsetpos"); - ImportFromCLIB(nlmHandle, &gpf_ftell, "ftell"); - ImportFromCLIB(nlmHandle, &gpf_fwrite, "fwrite"); - ImportFromCLIB(nlmHandle, &gpf_getc, "getc"); - ImportFromCLIB(nlmHandle, &gpf_getchar, "getchar"); - ImportFromCLIB(nlmHandle, &gpf_gets, "gets"); - ImportFromCLIB(nlmHandle, &gpf_perror, "perror"); - ImportFromCLIB(nlmHandle, &gpf_putc, "putc"); - ImportFromCLIB(nlmHandle, &gpf_putchar, "putchar"); - ImportFromCLIB(nlmHandle, &gpf_puts, "puts"); - ImportFromCLIB(nlmHandle, &gpf_rename, "rename"); - ImportFromCLIB(nlmHandle, &gpf_rewind, "rewind"); - ImportFromCLIB(nlmHandle, &gpf_scanf, "scanf"); - ImportFromCLIB(nlmHandle, &gpf_setbuf, "setbuf"); - ImportFromCLIB(nlmHandle, &gpf_setvbuf, "setvbuf"); - ImportFromCLIB(nlmHandle, &gpf_sscanf, "sscanf"); - ImportFromCLIB(nlmHandle, &gpf_tmpfile, "tmpfile"); - ImportFromCLIB(nlmHandle, &gpf_tmpnam, "tmpnam"); - ImportFromCLIB(nlmHandle, &gpf_ungetc, "ungetc"); - ImportFromCLIB(nlmHandle, &gpf_vfscanf, "vfscanf"); - ImportFromCLIB(nlmHandle, &gpf_vscanf, "vscanf"); - ImportFromCLIB(nlmHandle, &gpf_vsscanf, "vsscanf"); - ImportFromCLIB(nlmHandle, &gpf_fdopen, "fdopen"); - ImportFromCLIB(nlmHandle, &gpf_fileno, "fileno"); - ImportFromCLIB(nlmHandle, &gpf_cgets, "cgets"); - ImportFromCLIB(nlmHandle, &gpf_cprintf, "cprintf"); - ImportFromCLIB(nlmHandle, &gpf_cputs, "cputs"); - ImportFromCLIB(nlmHandle, &gpf_cscanf, "cscanf"); - ImportFromCLIB(nlmHandle, &gpf_fcloseall, "fcloseall"); - ImportFromCLIB(nlmHandle, &gpf_fgetchar, "fgetchar"); - ImportFromCLIB(nlmHandle, &gpf_flushall, "flushall"); - ImportFromCLIB(nlmHandle, &gpf_fputchar, "fputchar"); - ImportFromCLIB(nlmHandle, &gpf_getch, "getch"); - ImportFromCLIB(nlmHandle, &gpf_getche, "getche"); - ImportFromCLIB(nlmHandle, &gpf_putch, "putch"); - ImportFromCLIB(nlmHandle, &gpf_ungetch, "ungetch"); - ImportFromCLIB(nlmHandle, &gpf_vcprintf, "vcprintf"); - ImportFromCLIB(nlmHandle, &gpf_vcscanf, "vcscanf"); - - ImportFromCLIB(nlmHandle, &gpf_memchr, "memchr"); - ImportFromCLIB(nlmHandle, &gpf_memcmp, "memcmp"); - ImportFromCLIB(nlmHandle, &gpf_memcpy, "memcpy"); - ImportFromCLIB(nlmHandle, &gpf_memmove, "memmove"); - ImportFromCLIB(nlmHandle, &gpf_memset, "memset"); - ImportFromCLIB(nlmHandle, &gpf_memicmp, "memicmp"); - - ImportFromCLIB(nlmHandle, &gpf_strerror, "strerror"); - ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); - - ImportFromCLIB(nlmHandle, &gpf_strcpy, "strcpy"); - ImportFromCLIB(nlmHandle, &gpf_strcat, "strcat"); - ImportFromCLIB(nlmHandle, &gpf_strchr, "strchr"); - ImportFromCLIB(nlmHandle, &gpf_strstr, "strstr"); - ImportFromCLIB(nlmHandle, &gpf_strcoll, "strcoll"); - ImportFromCLIB(nlmHandle, &gpf_strcspn, "strcspn"); - ImportFromCLIB(nlmHandle, &gpf_strpbrk, "strpbrk"); - ImportFromCLIB(nlmHandle, &gpf_strrchr, "strrchr"); - ImportFromCLIB(nlmHandle, &gpf_strrev, "strrev"); - ImportFromCLIB(nlmHandle, &gpf_strspn, "strspn"); - ImportFromCLIB(nlmHandle, &gpf_strupr, "strupr"); - ImportFromCLIB(nlmHandle, &gpf_strxfrm, "strxfrm"); - ImportFromCLIB(nlmHandle, &gpf_strcmp, "strcmp"); - ImportFromCLIB(nlmHandle, &gpf_stricmp, "stricmp"); - ImportFromCLIB(nlmHandle, &gpf_strtok, "strtok"); - ImportFromCLIB(nlmHandle, &gpf_strlen, "strlen"); - ImportFromCLIB(nlmHandle, &gpf_strncpy, "strncpy"); - ImportFromCLIB(nlmHandle, &gpf_strncat, "strncat"); - ImportFromCLIB(nlmHandle, &gpf_strncmp, "strncmp"); - ImportFromCLIB(nlmHandle, &gpf_strcmpi, "strcmpi"); - ImportFromCLIB(nlmHandle, &gpf_strnicmp, "strnicmp"); - ImportFromCLIB(nlmHandle, &gpf_strdup, "strdup"); - ImportFromCLIB(nlmHandle, &gpf_strlist, "strlist"); - ImportFromCLIB(nlmHandle, &gpf_strlwr, "strlwr"); - ImportFromCLIB(nlmHandle, &gpf_strnset, "strnset"); - ImportFromCLIB(nlmHandle, &gpf_strset, "strset"); - ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); - ImportFromCLIB(nlmHandle, &gpf_printf, "printf"); - ImportFromCLIB(nlmHandle, &gpf_fprintf, "fprintf"); - ImportFromCLIB(nlmHandle, &gpf_sprintf, "sprintf"); - ImportFromCLIB(nlmHandle, &gpf_vprintf, "vprintf"); - ImportFromCLIB(nlmHandle, &gpf_vfprintf, "vfprintf"); - ImportFromCLIB(nlmHandle, &gpf_vsprintf, "vsprintf"); + unsigned int nlmHandle = GetNLMHandle(); + + ImportFromCLIB(nlmHandle, &gpf___get_stdin, "__get_stdin"); + ImportFromCLIB(nlmHandle, &gpf___get_stdout, "__get_stdout"); + ImportFromCLIB(nlmHandle, &gpf___get_stderr, "__get_stderr"); + ImportFromCLIB(nlmHandle, &gpf_clearerr, "clearerr"); + ImportFromCLIB(nlmHandle, &gpf_fclose, "fclose"); + ImportFromCLIB(nlmHandle, &gpf_feof, "feof"); + ImportFromCLIB(nlmHandle, &gpf_ferror, "ferror"); + ImportFromCLIB(nlmHandle, &gpf_fflush, "fflush"); + ImportFromCLIB(nlmHandle, &gpf_fgetc, "fgetc"); + ImportFromCLIB(nlmHandle, &gpf_fgetpos, "fgetpos"); + ImportFromCLIB(nlmHandle, &gpf_fgets, "fgets"); + ImportFromCLIB(nlmHandle, &gpf_fopen, "fopen"); + ImportFromCLIB(nlmHandle, &gpf_fputc, "fputc"); + ImportFromCLIB(nlmHandle, &gpf_fputs, "fputs"); + ImportFromCLIB(nlmHandle, &gpf_fread, "fread"); + ImportFromCLIB(nlmHandle, &gpf_freopen, "freopen"); + ImportFromCLIB(nlmHandle, &gpf_fscanf, "fscanf"); + ImportFromCLIB(nlmHandle, &gpf_fseek, "fseek"); + ImportFromCLIB(nlmHandle, &gpf_fsetpos, "fsetpos"); + ImportFromCLIB(nlmHandle, &gpf_ftell, "ftell"); + ImportFromCLIB(nlmHandle, &gpf_fwrite, "fwrite"); + ImportFromCLIB(nlmHandle, &gpf_getc, "getc"); + ImportFromCLIB(nlmHandle, &gpf_getchar, "getchar"); + ImportFromCLIB(nlmHandle, &gpf_gets, "gets"); + ImportFromCLIB(nlmHandle, &gpf_perror, "perror"); + ImportFromCLIB(nlmHandle, &gpf_putc, "putc"); + ImportFromCLIB(nlmHandle, &gpf_putchar, "putchar"); + ImportFromCLIB(nlmHandle, &gpf_puts, "puts"); + ImportFromCLIB(nlmHandle, &gpf_rename, "rename"); + ImportFromCLIB(nlmHandle, &gpf_rewind, "rewind"); + ImportFromCLIB(nlmHandle, &gpf_scanf, "scanf"); + ImportFromCLIB(nlmHandle, &gpf_setbuf, "setbuf"); + ImportFromCLIB(nlmHandle, &gpf_setvbuf, "setvbuf"); + ImportFromCLIB(nlmHandle, &gpf_sscanf, "sscanf"); + ImportFromCLIB(nlmHandle, &gpf_tmpfile, "tmpfile"); + ImportFromCLIB(nlmHandle, &gpf_tmpnam, "tmpnam"); + ImportFromCLIB(nlmHandle, &gpf_ungetc, "ungetc"); + ImportFromCLIB(nlmHandle, &gpf_vfscanf, "vfscanf"); + ImportFromCLIB(nlmHandle, &gpf_vscanf, "vscanf"); + ImportFromCLIB(nlmHandle, &gpf_vsscanf, "vsscanf"); + ImportFromCLIB(nlmHandle, &gpf_fdopen, "fdopen"); + ImportFromCLIB(nlmHandle, &gpf_fileno, "fileno"); + ImportFromCLIB(nlmHandle, &gpf_cgets, "cgets"); + ImportFromCLIB(nlmHandle, &gpf_cprintf, "cprintf"); + ImportFromCLIB(nlmHandle, &gpf_cputs, "cputs"); + ImportFromCLIB(nlmHandle, &gpf_cscanf, "cscanf"); + ImportFromCLIB(nlmHandle, &gpf_fcloseall, "fcloseall"); + ImportFromCLIB(nlmHandle, &gpf_fgetchar, "fgetchar"); + ImportFromCLIB(nlmHandle, &gpf_flushall, "flushall"); + ImportFromCLIB(nlmHandle, &gpf_fputchar, "fputchar"); + ImportFromCLIB(nlmHandle, &gpf_getch, "getch"); + ImportFromCLIB(nlmHandle, &gpf_getche, "getche"); + ImportFromCLIB(nlmHandle, &gpf_putch, "putch"); + ImportFromCLIB(nlmHandle, &gpf_ungetch, "ungetch"); + ImportFromCLIB(nlmHandle, &gpf_vcprintf, "vcprintf"); + ImportFromCLIB(nlmHandle, &gpf_vcscanf, "vcscanf"); + + ImportFromCLIB(nlmHandle, &gpf_memchr, "memchr"); + ImportFromCLIB(nlmHandle, &gpf_memcmp, "memcmp"); + ImportFromCLIB(nlmHandle, &gpf_memcpy, "memcpy"); + ImportFromCLIB(nlmHandle, &gpf_memmove, "memmove"); + ImportFromCLIB(nlmHandle, &gpf_memset, "memset"); + ImportFromCLIB(nlmHandle, &gpf_memicmp, "memicmp"); + + ImportFromCLIB(nlmHandle, &gpf_strerror, "strerror"); + ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); + + ImportFromCLIB(nlmHandle, &gpf_strcpy, "strcpy"); + ImportFromCLIB(nlmHandle, &gpf_strcat, "strcat"); + ImportFromCLIB(nlmHandle, &gpf_strchr, "strchr"); + ImportFromCLIB(nlmHandle, &gpf_strstr, "strstr"); + ImportFromCLIB(nlmHandle, &gpf_strcoll, "strcoll"); + ImportFromCLIB(nlmHandle, &gpf_strcspn, "strcspn"); + ImportFromCLIB(nlmHandle, &gpf_strpbrk, "strpbrk"); + ImportFromCLIB(nlmHandle, &gpf_strrchr, "strrchr"); + ImportFromCLIB(nlmHandle, &gpf_strrev, "strrev"); + ImportFromCLIB(nlmHandle, &gpf_strspn, "strspn"); + ImportFromCLIB(nlmHandle, &gpf_strupr, "strupr"); + ImportFromCLIB(nlmHandle, &gpf_strxfrm, "strxfrm"); + ImportFromCLIB(nlmHandle, &gpf_strcmp, "strcmp"); + ImportFromCLIB(nlmHandle, &gpf_stricmp, "stricmp"); + ImportFromCLIB(nlmHandle, &gpf_strtok, "strtok"); + ImportFromCLIB(nlmHandle, &gpf_strlen, "strlen"); + ImportFromCLIB(nlmHandle, &gpf_strncpy, "strncpy"); + ImportFromCLIB(nlmHandle, &gpf_strncat, "strncat"); + ImportFromCLIB(nlmHandle, &gpf_strncmp, "strncmp"); + ImportFromCLIB(nlmHandle, &gpf_strcmpi, "strcmpi"); + ImportFromCLIB(nlmHandle, &gpf_strnicmp, "strnicmp"); + ImportFromCLIB(nlmHandle, &gpf_strdup, "strdup"); + ImportFromCLIB(nlmHandle, &gpf_strlist, "strlist"); + ImportFromCLIB(nlmHandle, &gpf_strlwr, "strlwr"); + ImportFromCLIB(nlmHandle, &gpf_strnset, "strnset"); + ImportFromCLIB(nlmHandle, &gpf_strset, "strset"); + ImportFromCLIB(nlmHandle, &gpf_strtok_r, "strtok_r"); + ImportFromCLIB(nlmHandle, &gpf_printf, "printf"); + ImportFromCLIB(nlmHandle, &gpf_fprintf, "fprintf"); + ImportFromCLIB(nlmHandle, &gpf_sprintf, "sprintf"); + ImportFromCLIB(nlmHandle, &gpf_vprintf, "vprintf"); + ImportFromCLIB(nlmHandle, &gpf_vfprintf, "vfprintf"); + ImportFromCLIB(nlmHandle, &gpf_vsprintf, "vsprintf"); } diff --git a/NetWare/NWTInfo.c b/NetWare/NWTInfo.c index b057d56b2a..a1221e703c 100644 --- a/NetWare/NWTInfo.c +++ b/NetWare/NWTInfo.c @@ -23,10 +23,10 @@ #include "nwtinfo.h" #ifdef MPK_ON - #include <mpktypes.h> - #include <mpkapis.h> + #include <mpktypes.h> + #include <mpkapis.h> #else - #include <nwsemaph.h> + #include <nwsemaph.h> #endif //MPK_ON // Number of entries in the hashtable @@ -42,11 +42,11 @@ // Semaphore to control access to global linked list // #ifdef MPK_ON - static SEMAPHORE g_tinfoSem = NULL; - static SEMAPHORE g_tCtxSem = NULL; + static SEMAPHORE g_tinfoSem = NULL; + static SEMAPHORE g_tCtxSem = NULL; #else - static LONG g_tinfoSem = 0L; - static LONG g_tCtxSem = 0L; + static LONG g_tinfoSem = 0L; + static LONG g_tCtxSem = 0L; #endif //MPK_ON // Hash table of thread information structures @@ -70,37 +70,37 @@ ThreadContext* g_ThreadCtx; BOOL fnTerminateThreadInfo(void) { - int index = 0; - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - for (index = 0; index < NUM_ENTRIES; index++) - { - if (g_ThreadInfo[index] != NULL) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - return FALSE; - } - } - #ifdef MPK_ON - kSemaphoreFree(g_tinfoSem); - g_tinfoSem = NULL; - #else - CloseLocalSemaphore(g_tinfoSem); - g_tinfoSem = 0; - #endif //MPK_ON - } - - return TRUE; + int index = 0; + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + for (index = 0; index < NUM_ENTRIES; index++) + { + if (g_ThreadInfo[index] != NULL) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + return FALSE; + } + } + #ifdef MPK_ON + kSemaphoreFree(g_tinfoSem); + g_tinfoSem = NULL; + #else + CloseLocalSemaphore(g_tinfoSem); + g_tinfoSem = 0; + #endif //MPK_ON + } + + return TRUE; } @@ -109,7 +109,7 @@ BOOL fnTerminateThreadInfo(void) Function : fnInitializeThreadInfo Description : Initializes the global ThreadInfo hashtable and semaphore. - Call once per NLM instance + Call once per NLM instance Parameters : None. @@ -119,22 +119,22 @@ BOOL fnTerminateThreadInfo(void) void fnInitializeThreadInfo(void) { - int index = 0; + int index = 0; - if (g_tinfoSem) - return; + if (g_tinfoSem) + return; - #ifdef MPK_ON - g_tinfoSem = kSemaphoreAlloc((BYTE *)"threadInfo", 1); - #else - g_tinfoSem = OpenLocalSemaphore(1); - #endif //MPK_ON - + #ifdef MPK_ON + g_tinfoSem = kSemaphoreAlloc((BYTE *)"threadInfo", 1); + #else + g_tinfoSem = OpenLocalSemaphore(1); + #endif //MPK_ON + - for (index = 0; index < NUM_ENTRIES; index++) - g_ThreadInfo[index] = NULL; + for (index = 0; index < NUM_ENTRIES; index++) + g_ThreadInfo[index] = NULL; - return; + return; } @@ -152,18 +152,18 @@ void fnInitializeThreadInfo(void) BOOL fnRegisterWithThreadTable(void) { - ThreadInfo* tinfo = NULL; - - #ifdef MPK_ON - tinfo = fnAddThreadInfo(labs((int)kCurrentThread())); - #else - tinfo = fnAddThreadInfo(GetThreadID()); - #endif //MPK_ON - - if (!tinfo) - return FALSE; - else - return TRUE; + ThreadInfo* tinfo = NULL; + + #ifdef MPK_ON + tinfo = fnAddThreadInfo(labs((int)kCurrentThread())); + #else + tinfo = fnAddThreadInfo(GetThreadID()); + #endif //MPK_ON + + if (!tinfo) + return FALSE; + else + return TRUE; } @@ -181,11 +181,11 @@ BOOL fnRegisterWithThreadTable(void) BOOL fnUnregisterWithThreadTable(void) { - #ifdef MPK_ON - return fnRemoveThreadInfo(labs((int)kCurrentThread())); - #else - return fnRemoveThreadInfo(GetThreadID()); - #endif //MPK_ON + #ifdef MPK_ON + return fnRemoveThreadInfo(labs((int)kCurrentThread())); + #else + return fnRemoveThreadInfo(GetThreadID()); + #endif //MPK_ON } @@ -203,50 +203,50 @@ BOOL fnUnregisterWithThreadTable(void) ThreadInfo* fnAddThreadInfo(int tid) { - ThreadInfo* tip = NULL; - int index = 0; - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - // Add a new one to the beginning of the hash entry - // - tip = (ThreadInfo *) malloc(sizeof(ThreadInfo)); - if (tip == NULL) - { - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - return NULL; - } - index = INDEXOF(tid); // just take the bottom five bits - tip->next = g_ThreadInfo[index]; - tip->tid = tid; - tip->m_dontTouchHashLists = FALSE; - tip->m_allocList = NULL; - - g_ThreadInfo [index] = tip; - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return tip; + ThreadInfo* tip = NULL; + int index = 0; + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + // Add a new one to the beginning of the hash entry + // + tip = (ThreadInfo *) malloc(sizeof(ThreadInfo)); + if (tip == NULL) + { + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + return NULL; + } + index = INDEXOF(tid); // just take the bottom five bits + tip->next = g_ThreadInfo[index]; + tip->tid = tid; + tip->m_dontTouchHashLists = FALSE; + tip->m_allocList = NULL; + + g_ThreadInfo [index] = tip; + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return tip; } @@ -255,7 +255,7 @@ ThreadInfo* fnAddThreadInfo(int tid) Function : fnRemoveThreadInfo Description : Frees the specified thread info structure and removes it from the - global linked list. + global linked list. Parameters : tid (IN) - ID of the thread. @@ -265,54 +265,54 @@ ThreadInfo* fnAddThreadInfo(int tid) BOOL fnRemoveThreadInfo(int tid) { - ThreadInfo* tip = NULL; - ThreadInfo* prevt = NULL; - int index = INDEXOF(tid); // just take the bottom five bits - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) - { - if (tip->tid == tid) - { - if (prevt == NULL) - g_ThreadInfo[index] = tip->next; - else - prevt->next = tip->next; - - free(tip); - tip=NULL; - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return TRUE; - } - prevt = tip; - } - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return FALSE; // entry not found + ThreadInfo* tip = NULL; + ThreadInfo* prevt = NULL; + int index = INDEXOF(tid); // just take the bottom five bits + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) + { + if (tip->tid == tid) + { + if (prevt == NULL) + g_ThreadInfo[index] = tip->next; + else + prevt->next = tip->next; + + free(tip); + tip=NULL; + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return TRUE; + } + prevt = tip; + } + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return FALSE; // entry not found } @@ -330,153 +330,153 @@ BOOL fnRemoveThreadInfo(int tid) ThreadInfo* fnGetThreadInfo(int tid) { - ThreadInfo* tip; - int index = INDEXOF(tid); // just take the bottom five bits - - if (g_tinfoSem) { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - // see if this is already in the table at the index'th offset - // - for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) - { - if (tip->tid == tid) - { - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - return tip; - } - } - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return NULL; + ThreadInfo* tip; + int index = INDEXOF(tid); // just take the bottom five bits + + if (g_tinfoSem) { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + // see if this is already in the table at the index'th offset + // + for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) + { + if (tip->tid == tid) + { + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + return tip; + } + } + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return NULL; } BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList) { - ThreadInfo* tip; - int index,tid; - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - #ifdef MPK_ON - tid=index = abs(kCurrentThread()); - #else - tid=index = GetThreadID(); - #endif //MPK_ON - - index = INDEXOF(index); // just take the bottom five bits - - // see if this is already in the table at the index'th offset - // - for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) - { - if (tip->tid == tid) - { - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - tip->m_allocList = addrs; - tip->m_dontTouchHashLists = dontTouchHashList; - return TRUE; - } - } - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return FALSE; + ThreadInfo* tip; + int index,tid; + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + #ifdef MPK_ON + tid=index = abs(kCurrentThread()); + #else + tid=index = GetThreadID(); + #endif //MPK_ON + + index = INDEXOF(index); // just take the bottom five bits + + // see if this is already in the table at the index'th offset + // + for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) + { + if (tip->tid == tid) + { + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + tip->m_allocList = addrs; + tip->m_dontTouchHashLists = dontTouchHashList; + return TRUE; + } + } + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return FALSE; } BOOL fnGetHashListAddrs(void **addrs, BOOL *dontTouchHashList) { - ThreadInfo* tip; - int index,tid; - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tinfoSem); - #else - WaitOnLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - #ifdef MPK_ON - tid=index = abs(kCurrentThread()); - #else - tid=index = GetThreadID(); - #endif //MPK_ON - - index = INDEXOF(index); // just take the bottom five bits - - // see if this is already in the table at the index'th offset - // - for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) - { - if (tip->tid == tid) - { - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - *addrs = tip->m_allocList; - *dontTouchHashList = tip->m_dontTouchHashLists; - return TRUE; - } - } - - if (g_tinfoSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tinfoSem); - #else - SignalLocalSemaphore(g_tinfoSem); - #endif //MPK_ON - } - - return FALSE; + ThreadInfo* tip; + int index,tid; + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tinfoSem); + #else + WaitOnLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + #ifdef MPK_ON + tid=index = abs(kCurrentThread()); + #else + tid=index = GetThreadID(); + #endif //MPK_ON + + index = INDEXOF(index); // just take the bottom five bits + + // see if this is already in the table at the index'th offset + // + for (tip = g_ThreadInfo[index]; tip != NULL; tip = tip->next) + { + if (tip->tid == tid) + { + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + *addrs = tip->m_allocList; + *dontTouchHashList = tip->m_dontTouchHashLists; + return TRUE; + } + } + + if (g_tinfoSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tinfoSem); + #else + SignalLocalSemaphore(g_tinfoSem); + #endif //MPK_ON + } + + return FALSE; } @@ -494,20 +494,20 @@ BOOL fnGetHashListAddrs(void **addrs, BOOL *dontTouchHashList) long fnInitializeThreadCtx(void) { - int index = 0; - //long tid; + int index = 0; + //long tid; - if (!g_tCtxSem) { - #ifdef MPK_ON - g_tCtxSem = kSemaphoreAlloc((BYTE *)"threadCtx", 1); - #else - g_tCtxSem = OpenLocalSemaphore(1); - #endif //MPK_ON + if (!g_tCtxSem) { + #ifdef MPK_ON + g_tCtxSem = kSemaphoreAlloc((BYTE *)"threadCtx", 1); + #else + g_tCtxSem = OpenLocalSemaphore(1); + #endif //MPK_ON - g_ThreadCtx =NULL; - } + g_ThreadCtx =NULL; + } - return 0l; + return 0l; } @@ -518,7 +518,7 @@ long fnInitializeThreadCtx(void) Description : Add a new thread context. Parameters : lTLSIndex (IN) - Index - t (IN) - void pointer. + t (IN) - void pointer. Returns : Pointer to ThreadContext structure. @@ -526,67 +526,67 @@ long fnInitializeThreadCtx(void) ThreadContext* fnAddThreadCtx(long lTLSIndex, void *t) { - ThreadContext* tip = NULL; - ThreadContext* temp = NULL; - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tCtxSem); - #else - WaitOnLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - - // add a new one to the beginning of the list - // - tip = (ThreadContext *) malloc(sizeof(ThreadContext)); - if (tip == NULL) - { - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - return NULL; - } - - #ifdef MPK_ON - lTLSIndex = labs(kCurrentThread()); - #else - lTLSIndex = GetThreadID(); - #endif //MPK_ON - - tip->next = NULL; - tip->tid = lTLSIndex; - tip->tInfo = t; - - if(g_ThreadCtx==NULL) { - g_ThreadCtx = tip; - } else { - int count=0; - //Traverse to the end - temp = g_ThreadCtx; - while(temp->next != NULL) - { - temp = temp->next; - count++; - } - temp->next = tip; - } - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - return tip; + ThreadContext* tip = NULL; + ThreadContext* temp = NULL; + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tCtxSem); + #else + WaitOnLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + + // add a new one to the beginning of the list + // + tip = (ThreadContext *) malloc(sizeof(ThreadContext)); + if (tip == NULL) + { + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + return NULL; + } + + #ifdef MPK_ON + lTLSIndex = labs(kCurrentThread()); + #else + lTLSIndex = GetThreadID(); + #endif //MPK_ON + + tip->next = NULL; + tip->tid = lTLSIndex; + tip->tInfo = t; + + if(g_ThreadCtx==NULL) { + g_ThreadCtx = tip; + } else { + int count=0; + //Traverse to the end + temp = g_ThreadCtx; + while(temp->next != NULL) + { + temp = temp->next; + count++; + } + temp->next = tip; + } + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + return tip; } @@ -604,58 +604,58 @@ ThreadContext* fnAddThreadCtx(long lTLSIndex, void *t) BOOL fnRemoveThreadCtx(long lTLSIndex) { - ThreadContext* tip = NULL; - ThreadContext* prevt = NULL; - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tCtxSem); - #else - WaitOnLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - - #ifdef MPK_ON - lTLSIndex = labs(kCurrentThread()); - #else - lTLSIndex = GetThreadID(); - #endif //MPK_ON - - tip = g_ThreadCtx; - while(tip) { - if (tip->tid == lTLSIndex) { - if (prevt == NULL) - g_ThreadCtx = tip->next; - else - prevt->next = tip->next; - - free(tip); - tip=NULL; - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - return TRUE; - } - prevt = tip; - tip = tip->next; - } - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - - return FALSE; // entry not found + ThreadContext* tip = NULL; + ThreadContext* prevt = NULL; + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tCtxSem); + #else + WaitOnLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + + #ifdef MPK_ON + lTLSIndex = labs(kCurrentThread()); + #else + lTLSIndex = GetThreadID(); + #endif //MPK_ON + + tip = g_ThreadCtx; + while(tip) { + if (tip->tid == lTLSIndex) { + if (prevt == NULL) + g_ThreadCtx = tip->next; + else + prevt->next = tip->next; + + free(tip); + tip=NULL; + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + return TRUE; + } + prevt = tip; + tip = tip->next; + } + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + + return FALSE; // entry not found } @@ -673,48 +673,48 @@ BOOL fnRemoveThreadCtx(long lTLSIndex) void* fnGetThreadCtx(long lTLSIndex) { - ThreadContext* tip; - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreWait(g_tCtxSem); - #else - WaitOnLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - - #ifdef MPK_ON - lTLSIndex = labs(kCurrentThread()); - #else - lTLSIndex = GetThreadID(); - #endif //MPK_ON - - tip = g_ThreadCtx; - while(tip) { - if (tip->tid == lTLSIndex) { - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - return (tip->tInfo); - } - tip=tip->next; - } - - if (g_tCtxSem) - { - #ifdef MPK_ON - kSemaphoreSignal(g_tCtxSem); - #else - SignalLocalSemaphore(g_tCtxSem); - #endif //MPK_ON - } - - return NULL; + ThreadContext* tip; + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreWait(g_tCtxSem); + #else + WaitOnLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + + #ifdef MPK_ON + lTLSIndex = labs(kCurrentThread()); + #else + lTLSIndex = GetThreadID(); + #endif //MPK_ON + + tip = g_ThreadCtx; + while(tip) { + if (tip->tid == lTLSIndex) { + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + return (tip->tInfo); + } + tip=tip->next; + } + + if (g_tCtxSem) + { + #ifdef MPK_ON + kSemaphoreSignal(g_tCtxSem); + #else + SignalLocalSemaphore(g_tCtxSem); + #endif //MPK_ON + } + + return NULL; } diff --git a/NetWare/NWUtil.c b/NetWare/NWUtil.c index 6d60dfbabd..bb39971f56 100644 --- a/NetWare/NWUtil.c +++ b/NetWare/NWUtil.c @@ -57,7 +57,7 @@ char *s2 = NULL; // Used in fnSkipToken. Function : fnSkipWhite Description : This function skips the white space characters in the given string and - returns the resultant value. + returns the resultant value. Parameters : s (IN) - Input string. @@ -67,9 +67,9 @@ char *s2 = NULL; // Used in fnSkipToken. char *fnSkipWhite(char *s) { - while (isspace(*s)) - s++; - return s; + while (isspace(*s)) + s++; + return s; } @@ -79,10 +79,10 @@ char *fnSkipWhite(char *s) Function : fnNwGetEnvironmentStr Description : This function returns the NetWare environment string if available, - otherwise returns the supplied default value + otherwise returns the supplied default value Parameters : name (IN) - To hold the NetWare environment value. - defaultvalue (IN) - Default value. + defaultvalue (IN) - Default value. Returns : String. @@ -91,10 +91,10 @@ char *fnSkipWhite(char *s) char *fnNwGetEnvironmentStr(char *name, char *defaultvalue) { - char* ret = getenv(name); - if (ret == NULL) - ret = defaultvalue; - return ret; + char* ret = getenv(name); + if (ret == NULL) + ret = defaultvalue; + return ret; } @@ -104,11 +104,11 @@ char *fnNwGetEnvironmentStr(char *name, char *defaultvalue) Function : fnCommandLineParser Description : This function parses the command line into argc/argv style of - Number of params and array of params. + Number of params and array of params. Parameters : pclp (IN) - CommandLine structure. - commandLine (IN) - CommandLine String. - preserverQuotes (IN) - Indicates whether to preserve/copy the quotes or not. + commandLine (IN) - CommandLine String. + preserverQuotes (IN) - Indicates whether to preserve/copy the quotes or not. Returns : Nothing. @@ -116,275 +116,275 @@ char *fnNwGetEnvironmentStr(char *name, char *defaultvalue) void fnCommandLineParser(PCOMMANDLINEPARSER pclp, char * commandLine, BOOL preserveQuotes) { - char *buffer = NULL; + char *buffer = NULL; - int index = 0; - int do_delete = 1; - int i=0, j=0, k=0; + int index = 0; + int do_delete = 1; + int i=0, j=0, k=0; - // +1 makes room for the terminating NULL - buffer = (char *) malloc((strlen(commandLine) + 1) * sizeof(char)); - if (buffer == NULL) - { - pclp->m_isValid = FALSE; - return; - } + // +1 makes room for the terminating NULL + buffer = (char *) malloc((strlen(commandLine) + 1) * sizeof(char)); + if (buffer == NULL) + { + pclp->m_isValid = FALSE; + return; + } - if (preserveQuotes) - { - // No I/O redirection nor quote processing if preserveQuotes + if (preserveQuotes) + { + // No I/O redirection nor quote processing if preserveQuotes - char *s = NULL; - char *sSkippedToken = NULL; + char *s = NULL; + char *sSkippedToken = NULL; - strcpy(buffer, commandLine); - s = buffer; - s = fnSkipWhite(s); // Skip white spaces. + strcpy(buffer, commandLine); + s = buffer; + s = fnSkipWhite(s); // Skip white spaces. - s2 = s; // Update the global pointer. + s2 = s; // Update the global pointer. - pclp->sSkippedToken = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->sSkippedToken == NULL) - { - pclp->m_isValid = FALSE; - return; - } + pclp->sSkippedToken = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->sSkippedToken == NULL) + { + pclp->m_isValid = FALSE; + return; + } - while (*s && pclp->m_isValid) - { + while (*s && pclp->m_isValid) + { /**** // Commented since only one time malloc and free is enough as is done outside this while loop. // It is not required to do them everytime the execution comes into this while loop. // Still retained here. Remove this once things are proved to be working fine to a good confident level, - if(pclp->sSkippedToken) - { - free(pclp->sSkippedToken); - pclp->sSkippedToken = NULL; - } - - if(pclp->sSkippedToken == NULL) - { - pclp->sSkippedToken = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->sSkippedToken == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } + if(pclp->sSkippedToken) + { + free(pclp->sSkippedToken); + pclp->sSkippedToken = NULL; + } + + if(pclp->sSkippedToken == NULL) + { + pclp->sSkippedToken = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->sSkippedToken == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } ****/ - // Empty the string. - strncpy(pclp->sSkippedToken, "", (MAX_DN_BYTES * sizeof(char))); - - // s is advanced by fnSkipToken - pclp->sSkippedToken = fnSkipToken(s, pclp->sSkippedToken); // Collect the next command-line argument. - - s2 = fnSkipWhite(s2); // s2 is already updated by fnSkipToken. - s = s2; // Update the local pointer too. - - fnAppendArgument(pclp, pclp->sSkippedToken); // Append the argument into an array. - } - - if(pclp->sSkippedToken) - { - free(pclp->sSkippedToken); - pclp->sSkippedToken = NULL; - } - } - else - { - char *s = NULL; - - strcpy(buffer, commandLine); - s = buffer; - s = fnSkipWhite(s); - - s1 = s; // Update the global pointer. - - while (*s && pclp->m_isValid) - { - // s is advanced by fnScanToken - // Check for I/O redirection here, *outside* of - // fnScanToken(), so that quote-protected angle - // brackets do NOT cause redirection. - if (*s == '<') - { - s = fnSkipWhite(s+1); // get stdin redirection - - if(pclp->m_redirInName) - { - free(pclp->m_redirInName); - pclp->m_redirInName = NULL; - } - - if(pclp->m_redirInName == NULL) - { - pclp->m_redirInName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->m_redirInName == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } - - // Collect the next command-line argument. - pclp->m_redirInName = fnScanToken(s, pclp->m_redirInName); - - s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. - s = s1; // Update the local pointer too. - } - else if (*s == '>') - { - s = fnSkipWhite(s+1); //get stdout redirection - - if(pclp->m_redirOutName) - { - free(pclp->m_redirOutName); - pclp->m_redirOutName = NULL; - } - - if(pclp->m_redirOutName == NULL) - { - pclp->m_redirOutName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->m_redirOutName == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } - - // Collect the next command-line argument. - pclp->m_redirOutName = fnScanToken(s, pclp->m_redirOutName); - - s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. - s = s1; // Update the local pointer too. - } - else if (*s == '2' && s[1] == '>') - { - s = fnSkipWhite(s+2); // get stderr redirection - - if(pclp->m_redirErrName) - { - free(pclp->m_redirErrName); - pclp->m_redirErrName = NULL; - } - - if(pclp->m_redirErrName == NULL) - { - pclp->m_redirErrName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->m_redirErrName == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } - - // Collect the next command-line argument. - pclp->m_redirErrName = fnScanToken(s, pclp->m_redirErrName); - - s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. - s = s1; // Update the local pointer too. - } - else if (*s == '&' && s[1] == '>') - { - s = fnSkipWhite(s+2); // get stdout+stderr redirection - - if(pclp->m_redirBothName) - { - free(pclp->m_redirBothName); - pclp->m_redirBothName = NULL; - } - - if(pclp->m_redirBothName == NULL) - { - pclp->m_redirBothName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->m_redirBothName == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } - - // Collect the next command-line argument. - pclp->m_redirBothName = fnScanToken(s, pclp->m_redirBothName); - - s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. - s = s1; // Update the local pointer too. - } - else - { - if(pclp->nextarg) - { - free(pclp->nextarg); - pclp->nextarg = NULL; - } - - if(pclp->nextarg == NULL) - { - pclp->nextarg = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(pclp->nextarg == NULL) - { - pclp->m_isValid = FALSE; - return; - } - } - - // Collect the next command-line argument. - pclp->nextarg = fnScanToken(s, pclp->nextarg); - - s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. - s = s1; // Update the local pointer too. - - // Append the next command-line argument into an array. - fnAppendArgument(pclp, pclp->nextarg); - } - } - } - - - // The -{ option, the --noscreen option, the --autodestroy option, if present, - // are processed now and removed from the argument vector. - for(index=0; index < pclp->m_argc; ) - { - // "-q" is replaced by "-{", because of clash with GetOpt - sgp - 7th Nov 2000 - // Copied from NDK build - Jan 5th 2001 - if (strncmp(pclp->m_argv[index], (char *)"-{", 2) == 0) - { - // found a -q option; grab the semaphore number - sscanf(pclp->m_argv[index], (char *)"-{%x", &pclp->m_qSemaphore); - fnDeleteArgument(pclp, index); // Delete the argument from the list. - } - else if (strcmp(pclp->m_argv[index], (char *)"--noscreen") == 0) - { - // found a --noscreen option - pclp->m_noScreen = 1; - fnDeleteArgument(pclp, index); - } - else if (strcmp(pclp->m_argv[index], (char *)"--autodestroy") == 0) - { - // found a --autodestroy option - create a screen but close automatically - pclp->m_AutoDestroy = 1; - fnDeleteArgument(pclp, index); - } - else - index++; - } - - // pclp->m_isValid is TRUE if there are more than 2 command line parameters OR - // if there is only one command and if it is the comman PERL. - pclp->m_isValid = ((pclp->m_argc >= 2) || ((pclp->m_argc > 0) && (stricmp(pclp->m_argv[0], LOAD_COMMAND) != 0))); - - if(buffer) - { - free(buffer); - buffer = NULL; - } - - return; + // Empty the string. + strncpy(pclp->sSkippedToken, "", (MAX_DN_BYTES * sizeof(char))); + + // s is advanced by fnSkipToken + pclp->sSkippedToken = fnSkipToken(s, pclp->sSkippedToken); // Collect the next command-line argument. + + s2 = fnSkipWhite(s2); // s2 is already updated by fnSkipToken. + s = s2; // Update the local pointer too. + + fnAppendArgument(pclp, pclp->sSkippedToken); // Append the argument into an array. + } + + if(pclp->sSkippedToken) + { + free(pclp->sSkippedToken); + pclp->sSkippedToken = NULL; + } + } + else + { + char *s = NULL; + + strcpy(buffer, commandLine); + s = buffer; + s = fnSkipWhite(s); + + s1 = s; // Update the global pointer. + + while (*s && pclp->m_isValid) + { + // s is advanced by fnScanToken + // Check for I/O redirection here, *outside* of + // fnScanToken(), so that quote-protected angle + // brackets do NOT cause redirection. + if (*s == '<') + { + s = fnSkipWhite(s+1); // get stdin redirection + + if(pclp->m_redirInName) + { + free(pclp->m_redirInName); + pclp->m_redirInName = NULL; + } + + if(pclp->m_redirInName == NULL) + { + pclp->m_redirInName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->m_redirInName == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } + + // Collect the next command-line argument. + pclp->m_redirInName = fnScanToken(s, pclp->m_redirInName); + + s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. + s = s1; // Update the local pointer too. + } + else if (*s == '>') + { + s = fnSkipWhite(s+1); //get stdout redirection + + if(pclp->m_redirOutName) + { + free(pclp->m_redirOutName); + pclp->m_redirOutName = NULL; + } + + if(pclp->m_redirOutName == NULL) + { + pclp->m_redirOutName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->m_redirOutName == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } + + // Collect the next command-line argument. + pclp->m_redirOutName = fnScanToken(s, pclp->m_redirOutName); + + s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. + s = s1; // Update the local pointer too. + } + else if (*s == '2' && s[1] == '>') + { + s = fnSkipWhite(s+2); // get stderr redirection + + if(pclp->m_redirErrName) + { + free(pclp->m_redirErrName); + pclp->m_redirErrName = NULL; + } + + if(pclp->m_redirErrName == NULL) + { + pclp->m_redirErrName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->m_redirErrName == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } + + // Collect the next command-line argument. + pclp->m_redirErrName = fnScanToken(s, pclp->m_redirErrName); + + s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. + s = s1; // Update the local pointer too. + } + else if (*s == '&' && s[1] == '>') + { + s = fnSkipWhite(s+2); // get stdout+stderr redirection + + if(pclp->m_redirBothName) + { + free(pclp->m_redirBothName); + pclp->m_redirBothName = NULL; + } + + if(pclp->m_redirBothName == NULL) + { + pclp->m_redirBothName = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->m_redirBothName == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } + + // Collect the next command-line argument. + pclp->m_redirBothName = fnScanToken(s, pclp->m_redirBothName); + + s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. + s = s1; // Update the local pointer too. + } + else + { + if(pclp->nextarg) + { + free(pclp->nextarg); + pclp->nextarg = NULL; + } + + if(pclp->nextarg == NULL) + { + pclp->nextarg = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(pclp->nextarg == NULL) + { + pclp->m_isValid = FALSE; + return; + } + } + + // Collect the next command-line argument. + pclp->nextarg = fnScanToken(s, pclp->nextarg); + + s1 = fnSkipWhite(s1); // s1 is already updated by fnScanToken. + s = s1; // Update the local pointer too. + + // Append the next command-line argument into an array. + fnAppendArgument(pclp, pclp->nextarg); + } + } + } + + + // The -{ option, the --noscreen option, the --autodestroy option, if present, + // are processed now and removed from the argument vector. + for(index=0; index < pclp->m_argc; ) + { + // "-q" is replaced by "-{", because of clash with GetOpt - sgp - 7th Nov 2000 + // Copied from NDK build - Jan 5th 2001 + if (strncmp(pclp->m_argv[index], (char *)"-{", 2) == 0) + { + // found a -q option; grab the semaphore number + sscanf(pclp->m_argv[index], (char *)"-{%x", &pclp->m_qSemaphore); + fnDeleteArgument(pclp, index); // Delete the argument from the list. + } + else if (strcmp(pclp->m_argv[index], (char *)"--noscreen") == 0) + { + // found a --noscreen option + pclp->m_noScreen = 1; + fnDeleteArgument(pclp, index); + } + else if (strcmp(pclp->m_argv[index], (char *)"--autodestroy") == 0) + { + // found a --autodestroy option - create a screen but close automatically + pclp->m_AutoDestroy = 1; + fnDeleteArgument(pclp, index); + } + else + index++; + } + + // pclp->m_isValid is TRUE if there are more than 2 command line parameters OR + // if there is only one command and if it is the comman PERL. + pclp->m_isValid = ((pclp->m_argc >= 2) || ((pclp->m_argc > 0) && (stricmp(pclp->m_argv[0], LOAD_COMMAND) != 0))); + + if(buffer) + { + free(buffer); + buffer = NULL; + } + + return; } @@ -396,7 +396,7 @@ void fnCommandLineParser(PCOMMANDLINEPARSER pclp, char * commandLine, BOOL prese Description : This function appends the arguments into a list. Parameters : pclp (IN) - CommandLine structure. - new_arg (IN) - The new argument to be appended. + new_arg (IN) - The new argument to be appended. Returns : Nothing. @@ -404,98 +404,98 @@ void fnCommandLineParser(PCOMMANDLINEPARSER pclp, char * commandLine, BOOL prese void fnAppendArgument(PCOMMANDLINEPARSER pclp, char *new_arg) { - char **new_argv = pclp->new_argv; - - int new_argv_len = pclp->m_argv_len*2; - int i = 0, j = 0; - - - // Lengthen the argument vector if there's not room for another. - // Testing for 'm_argc+2' rather than 'm_argc+1' in the test guarantees - // that there'll always be a NULL terminator at the end of argv. - if ((pclp->m_argc + 2) > pclp->m_argv_len) - { - new_argv = (char **) malloc(new_argv_len * sizeof(char*)); // get a longer arg-vector - if (new_argv == NULL) - { - pclp->m_isValid = FALSE; - return; - } - for(i=0; i<new_argv_len; i++) - { - new_argv[i] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if (new_argv[i] == NULL) - { - for(j=0; j<i; j++) - { - if(new_argv[j]) - { - free(new_argv[j]); - new_argv[j] = NULL; - } - } - if(new_argv) - { - free(new_argv); - new_argv = NULL; - } - - pclp->m_isValid = FALSE; - return; - } - } - - for (i=0; i<pclp->m_argc; i++) - strcpy(new_argv[i], pclp->m_argv[i]); // copy old arg strings - - for(i=0; i<(pclp->m_argv_len); i++) - { - if(pclp->m_argv[i]) - { - free(pclp->m_argv[i]); - pclp->m_argv[i] = NULL; - } - } - if (pclp->m_argv != NULL) - { - free(pclp->m_argv); - pclp->m_argv = NULL; - } - - - pclp->m_argv = new_argv; - pclp->m_argv_len = new_argv_len; - - } - - // Once m_argv is guaranteed long enough, appending the argument is a direct job. - strcpy(pclp->m_argv[pclp->m_argc], new_arg); // Appended the new argument. - pclp->m_argc++; // Increment the number of parameters appended. - - // The char array is emptied for all elements upto the end so that there are no - // junk characters. If this is not done, then the issue is like this: - // - Simple perl command like "perl" on the system console works fine for the first time. - // - When "perl" is executed the second time, a new blank screen should come up - // which allows for editing also. This was not consistently working well. - // More so when the command was like, "perl ", that is the name "perl" followed - // by a few blank spaces, it used to give error in opening file: - // "unable to open the file" since the filename would have some junk characters. - // - // These issues are fixed through the code below. - for(i=pclp->m_argc; i<pclp->m_argv_len; i++) - strncpy(pclp->m_argv[i], "", (MAX_DN_BYTES * sizeof(char))); // MAX_DN_BYTES is the size of pclp->m_argv[]. - - - // Fix for empty command line double quote abend - perl <.pl> "" - if ((new_arg==NULL) || ((strlen(new_arg))<=0)) - { - pclp->m_argc--; // Decrement the number of parameters appended. - pclp->m_isValid = FALSE; - return; - } - - - return; + char **new_argv = pclp->new_argv; + + int new_argv_len = pclp->m_argv_len*2; + int i = 0, j = 0; + + + // Lengthen the argument vector if there's not room for another. + // Testing for 'm_argc+2' rather than 'm_argc+1' in the test guarantees + // that there'll always be a NULL terminator at the end of argv. + if ((pclp->m_argc + 2) > pclp->m_argv_len) + { + new_argv = (char **) malloc(new_argv_len * sizeof(char*)); // get a longer arg-vector + if (new_argv == NULL) + { + pclp->m_isValid = FALSE; + return; + } + for(i=0; i<new_argv_len; i++) + { + new_argv[i] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if (new_argv[i] == NULL) + { + for(j=0; j<i; j++) + { + if(new_argv[j]) + { + free(new_argv[j]); + new_argv[j] = NULL; + } + } + if(new_argv) + { + free(new_argv); + new_argv = NULL; + } + + pclp->m_isValid = FALSE; + return; + } + } + + for (i=0; i<pclp->m_argc; i++) + strcpy(new_argv[i], pclp->m_argv[i]); // copy old arg strings + + for(i=0; i<(pclp->m_argv_len); i++) + { + if(pclp->m_argv[i]) + { + free(pclp->m_argv[i]); + pclp->m_argv[i] = NULL; + } + } + if (pclp->m_argv != NULL) + { + free(pclp->m_argv); + pclp->m_argv = NULL; + } + + + pclp->m_argv = new_argv; + pclp->m_argv_len = new_argv_len; + + } + + // Once m_argv is guaranteed long enough, appending the argument is a direct job. + strcpy(pclp->m_argv[pclp->m_argc], new_arg); // Appended the new argument. + pclp->m_argc++; // Increment the number of parameters appended. + + // The char array is emptied for all elements upto the end so that there are no + // junk characters. If this is not done, then the issue is like this: + // - Simple perl command like "perl" on the system console works fine for the first time. + // - When "perl" is executed the second time, a new blank screen should come up + // which allows for editing also. This was not consistently working well. + // More so when the command was like, "perl ", that is the name "perl" followed + // by a few blank spaces, it used to give error in opening file: + // "unable to open the file" since the filename would have some junk characters. + // + // These issues are fixed through the code below. + for(i=pclp->m_argc; i<pclp->m_argv_len; i++) + strncpy(pclp->m_argv[i], "", (MAX_DN_BYTES * sizeof(char))); // MAX_DN_BYTES is the size of pclp->m_argv[]. + + + // Fix for empty command line double quote abend - perl <.pl> "" + if ((new_arg==NULL) || ((strlen(new_arg))<=0)) + { + pclp->m_argc--; // Decrement the number of parameters appended. + pclp->m_isValid = FALSE; + return; + } + + + return; } @@ -505,11 +505,11 @@ void fnAppendArgument(PCOMMANDLINEPARSER pclp, char *new_arg) Function : fnSkipToken Description : This function collects the next command-line argument, breaking on - unquoted white space. The quote symbols are copied into the output. - White space has already been skipped. + unquoted white space. The quote symbols are copied into the output. + White space has already been skipped. Parameters : s (IN) - Input string in which the token is skipped. - r (IN) - The resultant return string. + r (IN) - The resultant return string. Returns : String. @@ -517,44 +517,44 @@ void fnAppendArgument(PCOMMANDLINEPARSER pclp, char *new_arg) char *fnSkipToken(char *s, char *r) { - char *t=NULL; - char quote = '\0'; // NULL, single quote, or double quote - char ch = '\0'; - - for (t=s; t[0]; t++) - { - ch = t[0]; - if (!quote) - { - if (isspace(ch)) // if unquoted whitespace... - { - break; // ...end of token found - } - else if (ch=='"' || ch=='\'') // if opening quote... - { - quote = ch; // ...enter quote mode - } - } - else - { - if (ch=='\\' && t[1]==quote) // if escaped quote... - { - t++; // ...skip backslash - } - else if (ch==quote) // if close quote... - { - quote = 0; // ...leave quote mode - } - } - } - - r = fnStashString(s, r, t-s); // get heap-allocated token string - t = fnSkipWhite(t); // skip any trailing white space - s = t; // return updated source pointer - - s2 = t; // return updated global source pointer - - return r; // return heap-allocated token string + char *t=NULL; + char quote = '\0'; // NULL, single quote, or double quote + char ch = '\0'; + + for (t=s; t[0]; t++) + { + ch = t[0]; + if (!quote) + { + if (isspace(ch)) // if unquoted whitespace... + { + break; // ...end of token found + } + else if (ch=='"' || ch=='\'') // if opening quote... + { + quote = ch; // ...enter quote mode + } + } + else + { + if (ch=='\\' && t[1]==quote) // if escaped quote... + { + t++; // ...skip backslash + } + else if (ch==quote) // if close quote... + { + quote = 0; // ...leave quote mode + } + } + } + + r = fnStashString(s, r, t-s); // get heap-allocated token string + t = fnSkipWhite(t); // skip any trailing white space + s = t; // return updated source pointer + + s2 = t; // return updated global source pointer + + return r; // return heap-allocated token string } @@ -564,12 +564,12 @@ char *fnSkipToken(char *s, char *r) Function : fnScanToken Description : This function collects the next command-line argument, breaking on - unquoted white space or I/O redirection symbols. Quote symbols are not - copied into the output. - When called, any leading white space has already been skipped. + unquoted white space or I/O redirection symbols. Quote symbols are not + copied into the output. + When called, any leading white space has already been skipped. Parameters : x (IN) - Input string in which the token is scanned. - r (IN) - The resultant return string. + r (IN) - The resultant return string. Returns : String. @@ -577,61 +577,61 @@ char *fnSkipToken(char *s, char *r) char *fnScanToken(char *x, char *r) { - char *s = x; // input string position - char *t = x; // output string position - char quote = '\0'; // either NULL, or single quote, or double quote - char ch = '\0'; - char c = '\0'; - - while (*s) - { - ch = *s; // invariant: ch != 0 - - // look to see if we've reached the end of the token - if (!quote) // but don't look for token break if we're inside quotes - { - if (isspace(ch)) - break; // break on whitespace - if (ch=='>') - break; // break on ">" (redirect stdout) - if (ch=='<') - break; // break on "<" (redirect stdin) - if (ch=='&' && x[1]=='>') - break; // break on "&>" (redirect both stdout & stderr) - } - - // process the next source character - if (ch=='\\' && (c=s[1]) && (c=='\\'||c=='>'||c=='<'||c==quote)) - { - //-----------------if an escaped '\\', '>', '<', or quote... - s++; // ...skip over the backslash... - *t++ = *s++; // ...and copy the escaped character - } - else if (ch==quote) // (won't match unless inside quotes because invariant ch!=0) - { - //-----------------if close quote... - s++; // ...skip over the quote... - quote=0; // ...and leave quote mode - } - else if (!quote && (ch=='"' || ch=='\'')) - { - //-----------------if opening quote... - quote = *s++; // ...enter quote mode (remembering quote char, and skipping the quote) - } - else - { //----------if normal character... - *t++ = *s++; // ...copy the character - } - } - - // clean up return values - r = fnStashString(x, r, t-x); // get heap-allocated token string - s = fnSkipWhite(s); // skip any trailing white space - x = s; // return updated source pointer - - s1 = s; // return updated global source pointer - - return r; + char *s = x; // input string position + char *t = x; // output string position + char quote = '\0'; // either NULL, or single quote, or double quote + char ch = '\0'; + char c = '\0'; + + while (*s) + { + ch = *s; // invariant: ch != 0 + + // look to see if we've reached the end of the token + if (!quote) // but don't look for token break if we're inside quotes + { + if (isspace(ch)) + break; // break on whitespace + if (ch=='>') + break; // break on ">" (redirect stdout) + if (ch=='<') + break; // break on "<" (redirect stdin) + if (ch=='&' && x[1]=='>') + break; // break on "&>" (redirect both stdout & stderr) + } + + // process the next source character + if (ch=='\\' && (c=s[1]) && (c=='\\'||c=='>'||c=='<'||c==quote)) + { + //-----------------if an escaped '\\', '>', '<', or quote... + s++; // ...skip over the backslash... + *t++ = *s++; // ...and copy the escaped character + } + else if (ch==quote) // (won't match unless inside quotes because invariant ch!=0) + { + //-----------------if close quote... + s++; // ...skip over the quote... + quote=0; // ...and leave quote mode + } + else if (!quote && (ch=='"' || ch=='\'')) + { + //-----------------if opening quote... + quote = *s++; // ...enter quote mode (remembering quote char, and skipping the quote) + } + else + { //----------if normal character... + *t++ = *s++; // ...copy the character + } + } + + // clean up return values + r = fnStashString(x, r, t-x); // get heap-allocated token string + s = fnSkipWhite(s); // skip any trailing white space + x = s; // return updated source pointer + + s1 = s; // return updated global source pointer + + return r; } @@ -643,8 +643,8 @@ char *fnScanToken(char *x, char *r) Description : This function return the heap-allocated token string. Parameters : s (IN) - Input string from which the token is extracted. - buffer (IN) - Return string. - length (IN) - Length of the token to be extracted. + buffer (IN) - Return string. + length (IN) - Length of the token to be extracted. Returns : String. @@ -652,19 +652,19 @@ char *fnScanToken(char *x, char *r) char *fnStashString(char *s, char *buffer, int length) { - if (length <= 0) - { - // Copy "" instead of NULL since "" indicates that there is memory allocated having no/null value. - // NULL indicates that there is no memory allocated to it! - strcpy(buffer, ""); - } - else - { - strncpy(buffer, s, length); - buffer[length] = '\0'; - } - - return buffer; + if (length <= 0) + { + // Copy "" instead of NULL since "" indicates that there is memory allocated having no/null value. + // NULL indicates that there is no memory allocated to it! + strcpy(buffer, ""); + } + else + { + strncpy(buffer, s, length); + buffer[length] = '\0'; + } + + return buffer; } @@ -676,7 +676,7 @@ char *fnStashString(char *s, char *buffer, int length) Description : This function deletes an argument (that was originally appended) from the list. Parameters : pclp (IN) - CommandLine structure. - index (IN) - Index of the argument to be deleted. + index (IN) - Index of the argument to be deleted. Returns : Nothing. @@ -684,33 +684,33 @@ char *fnStashString(char *s, char *buffer, int length) void fnDeleteArgument(PCOMMANDLINEPARSER pclp, int index) { - int i = index; + int i = index; - // If index is greater than the no. of arguments, just return. - if (index >= pclp->m_argc) - return; + // If index is greater than the no. of arguments, just return. + if (index >= pclp->m_argc) + return; - // Move all the arguments after the index one up. - while(i < (pclp->m_argv_len-1)) - { - strcpy(pclp->m_argv[i], pclp->m_argv[i+1]); - i++; - } + // Move all the arguments after the index one up. + while(i < (pclp->m_argv_len-1)) + { + strcpy(pclp->m_argv[i], pclp->m_argv[i+1]); + i++; + } - // Delete the last one and free memory. - if ( pclp->m_argv[i] ) - { - free(pclp->m_argv[i]); - pclp->m_argv[i] = NULL; - } + // Delete the last one and free memory. + if ( pclp->m_argv[i] ) + { + free(pclp->m_argv[i]); + pclp->m_argv[i] = NULL; + } - pclp->m_argc--; // Decrement the number of arguments. - pclp->m_argv_len--; + pclp->m_argc--; // Decrement the number of arguments. + pclp->m_argv_len--; - return; + return; } @@ -729,82 +729,82 @@ void fnDeleteArgument(PCOMMANDLINEPARSER pclp, int index) char* fnMy_MkTemp(char* templatestr) { - char* pXs=NULL; - char numbuf[50]={'\0'}; - int count=0; - char* pPid=NULL; + char* pXs=NULL; + char numbuf[50]={'\0'}; + int count=0; + char* pPid=NULL; - char termchar = '\0'; - char letter = 'a'; - char letter1 = 'a'; + char termchar = '\0'; + char letter = 'a'; + char letter1 = 'a'; - if (templatestr && (pXs = strstr(templatestr, (char *)"XXXXXX"))) - { - // generate temp name - termchar = pXs[6]; - ltoa(GetThreadID(), numbuf, 16); + if (templatestr && (pXs = strstr(templatestr, (char *)"XXXXXX"))) + { + // generate temp name + termchar = pXs[6]; + ltoa(GetThreadID(), numbuf, 16); // numbuf[sizeof(numbuf)-1] = '\0'; - numbuf[strlen(numbuf)-1] = '\0'; - // beware! thread IDs are 8 hex digits on NW 4.11 and only the - // lower digits seem to change, whereas on NW 5 they are in the - // range of < 1000 hex or 3 hex digits in length. So the following - // logic ensures we use the least significant portion of the number. - if (strlen(numbuf) > 5) - pPid = &numbuf[strlen(numbuf)-5]; - else - pPid = numbuf; + numbuf[strlen(numbuf)-1] = '\0'; + // beware! thread IDs are 8 hex digits on NW 4.11 and only the + // lower digits seem to change, whereas on NW 5 they are in the + // range of < 1000 hex or 3 hex digits in length. So the following + // logic ensures we use the least significant portion of the number. + if (strlen(numbuf) > 5) + pPid = &numbuf[strlen(numbuf)-5]; + else + pPid = numbuf; /** - Backtick operation uses temp files that are stored under NWDEFPERLTEMP - directory. They are temporarily used and then cleaned up after usage. - In cases where multiple backtick operations are used that call some - complex scripts, new temp files will be created before the old ones are - deleted. So, we need to have a provision to create many temp files. - Hence the below logic. It is found that provision for 26 files may - not be enough in some cases. - - This below logic allows 26 files (like, pla00015.tmp through plz00015.tmp) - plus 6x26=676 (like, plaa0015.tmp through plzz0015.tmp) + Backtick operation uses temp files that are stored under NWDEFPERLTEMP + directory. They are temporarily used and then cleaned up after usage. + In cases where multiple backtick operations are used that call some + complex scripts, new temp files will be created before the old ones are + deleted. So, we need to have a provision to create many temp files. + Hence the below logic. It is found that provision for 26 files may + not be enough in some cases. + + This below logic allows 26 files (like, pla00015.tmp through plz00015.tmp) + plus 6x26=676 (like, plaa0015.tmp through plzz0015.tmp) **/ - letter = 'a'; - do - { - sprintf(pXs, (char *)"%c%05.5s", letter, pPid); - pXs[6] = termchar; - if (access(templatestr, 0) != 0) // File does not exist - { - return templatestr; - } - letter++; - } while (letter <= 'z'); - - letter1 = 'a'; - do - { - letter = 'a'; - do - { - sprintf(pXs, (char *)"%c%c%04.5s", letter1, letter, pPid); - pXs[6] = termchar; - if (access(templatestr, 0) != 0) // File does not exist - { - return templatestr; - } - letter++; - } while (letter <= 'z'); - letter1++; - } while (letter1 <= 'z'); - - errno = ENOENT; - return NULL; - } - else - { - errno = EINVAL; - return NULL; - } + letter = 'a'; + do + { + sprintf(pXs, (char *)"%c%05.5s", letter, pPid); + pXs[6] = termchar; + if (access(templatestr, 0) != 0) // File does not exist + { + return templatestr; + } + letter++; + } while (letter <= 'z'); + + letter1 = 'a'; + do + { + letter = 'a'; + do + { + sprintf(pXs, (char *)"%c%c%04.5s", letter1, letter, pPid); + pXs[6] = termchar; + if (access(templatestr, 0) != 0) // File does not exist + { + return templatestr; + } + letter++; + } while (letter <= 'z'); + letter1++; + } while (letter1 <= 'z'); + + errno = ENOENT; + return NULL; + } + else + { + errno = EINVAL; + return NULL; + } } @@ -814,10 +814,10 @@ char* fnMy_MkTemp(char* templatestr) Function : fnSystemCommand Description : This function constructs a system command from the given - null-terminated argv array and runs the command on the system console. + null-terminated argv array and runs the command on the system console. Parameters : argv (IN) - Array of input commands. - argc (IN) - Number of input parameters. + argc (IN) - Number of input parameters. Returns : Nothing. @@ -825,34 +825,34 @@ char* fnMy_MkTemp(char* templatestr) void fnSystemCommand (char** argv, int argc) { - // calculate the size of a temp buffer needed - int k = 0; - int totalSize = 0; - int bytes = 0; - char* tempCmd = NULL; - char* tptr = NULL; + // calculate the size of a temp buffer needed + int k = 0; + int totalSize = 0; + int bytes = 0; + char* tempCmd = NULL; + char* tptr = NULL; - for(k=0; k<argc; k++) - totalSize += strlen(argv[k]) + 1; + for(k=0; k<argc; k++) + totalSize += strlen(argv[k]) + 1; - tempCmd = (char *) malloc((totalSize+1) * sizeof(char)); - if (!tempCmd) - return; - tptr = tempCmd; + tempCmd = (char *) malloc((totalSize+1) * sizeof(char)); + if (!tempCmd) + return; + tptr = tempCmd; - for(k=0; k<argc; k++) - tptr += sprintf(tptr, (char *)"%s ", argv[k]); - *tptr = 0; + for(k=0; k<argc; k++) + tptr += sprintf(tptr, (char *)"%s ", argv[k]); + *tptr = 0; - if (stricmp(argv[0], PERL_COMMAND_NAME) == 0) - fnInternalPerlLaunchHandler(tempCmd); // Launch perl. - else - system(tempCmd); + if (stricmp(argv[0], PERL_COMMAND_NAME) == 0) + fnInternalPerlLaunchHandler(tempCmd); // Launch perl. + else + system(tempCmd); - free(tempCmd); - tempCmd = NULL; - return; + free(tempCmd); + tempCmd = NULL; + return; } diff --git a/NetWare/Nwmain.c b/NetWare/Nwmain.c index 0b9728a8ac..c45513e736 100644 --- a/NetWare/Nwmain.c +++ b/NetWare/Nwmain.c @@ -35,8 +35,8 @@ #include "clibstuf.h" #ifdef MPK_ON - #include <mpktypes.h> - #include <mpkapis.h> + #include <mpktypes.h> + #include <mpkapis.h> #endif //MPK_ON @@ -44,9 +44,9 @@ // so it should be okay for this to be global. // #ifdef MPK_ON - THREAD gThreadHandle; + THREAD gThreadHandle; #else - int gThreadGroupID = -1; + int gThreadGroupID = -1; #endif //MPK_ON @@ -77,8 +77,8 @@ char sPerlScreenName[MAX_DN_BYTES * sizeof(char)] = {'\0'}; // typedef struct tagScriptData { - char *m_commandLine; - BOOL m_fromConsole; + char *m_commandLine; + BOOL m_fromConsole; }ScriptData; @@ -131,10 +131,10 @@ void nw_freeenviron(); Function : main Description : Called when the NLM is first loaded. Registers the command-line handler - and then terminates-stay-resident. + and then terminates-stay-resident. Parameters : argc (IN) - No of Input strings. - argv (IN) - Array of Input strings. + argv (IN) - Array of Input strings. Returns : Nothing. @@ -142,117 +142,117 @@ void nw_freeenviron(); void main(int argc, char *argv[]) { - char sysCmdLine[MAX_COMMAND_SIZE] = {'\0'}; - char cmdLineCopy[sizeof(PERL_COMMAND_NAME)+sizeof(sysCmdLine)+2] = {'\0'}; + char sysCmdLine[MAX_COMMAND_SIZE] = {'\0'}; + char cmdLineCopy[sizeof(PERL_COMMAND_NAME)+sizeof(sysCmdLine)+2] = {'\0'}; - ScriptData* psdata = NULL; + ScriptData* psdata = NULL; - // Keep this thread alive, since we use the thread group id of this thread to allocate memory on. - // When we unload the NLM, clib will tear the thread down. - // - #ifdef MPK_ON - gThreadHandle = kCurrentThread(); - #else - gThreadGroupID = GetThreadGroupID (); - #endif //MPK_ON + // Keep this thread alive, since we use the thread group id of this thread to allocate memory on. + // When we unload the NLM, clib will tear the thread down. + // + #ifdef MPK_ON + gThreadHandle = kCurrentThread(); + #else + gThreadGroupID = GetThreadGroupID (); + #endif //MPK_ON - signal (SIGTERM, fnSigTermHandler); - fnInitGpfGlobals(); // For importing the CLIB calls in place of the Watcom calls - fnInitializeThreadInfo(); + signal (SIGTERM, fnSigTermHandler); + fnInitGpfGlobals(); // For importing the CLIB calls in place of the Watcom calls + fnInitializeThreadInfo(); // Ensure that we have a "temp" directory - fnSetupNamespace(); - if (access(NWDEFPERLTEMP, 0) != 0) - mkdir(NWDEFPERLTEMP); - - // Create the file NUL if not present. This is done only once per NLM load. - // This is required for -e. - // Earlier versions were creating temporary files (in perl.c file) for -e. - // Now, the technique of creating temporary files are removed since they were - // fragile or insecure or slow. It now uses the memory by setting - // the BIT_BUCKET to "nul" on Win32, which is equivalent to /dev/nul of Unix. - // Since there is no equivalent of /dev/nul on NetWare, the work-around is that - // we create a file called "nul" and the BIT_BUCKET is set to "nul". - // This makes sure that -e works on NetWare too without the creation of temporary files - // in -e code in perl.c - { - char sNUL[MAX_DN_BYTES] = {'\0'}; - - strcpy(sNUL, NWDEFPERLROOT); - strcat(sNUL, "\\nwnul"); - if (access((const char *)sNUL, 0) != 0) - { - // The file, "nul" is not found and so create the file. - FILE *fp = NULL; - - fp = fopen((const char *)sNUL, (const char *)"w"); - fclose(fp); - } - } - - fnRegisterCommandLineHandler(); // Register the command line handler - SynchronizeStart(); // Restart the NLM startup process when using synchronization mode. - - fnGetPerlScreenName(sPerlScreenName); // Get the screen name. Done only once per NLM load. - - - // If the command line has two strings, then the first has to be "Perl" and the second is assumed - // to be a script to be run. If only one string (i.e., Perl) is input, then there is nothing to do! - // - if ((argc > 1) && getcmd(sysCmdLine)) - { - strcpy(cmdLineCopy, PERL_COMMAND_NAME); - strcat(cmdLineCopy, (char *)" "); // Space between the Perl Command and the input script name. - strcat(cmdLineCopy, sysCmdLine); // The command line parameters built into - - // Create a safe copy of the command line and pass it to the - // new thread for parsing. The new thread will be responsible - // to delete it when it is finished with it. - // - psdata = (ScriptData *) malloc(sizeof(ScriptData)); - if (psdata) - { - psdata->m_commandLine = NULL; - psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(psdata->m_commandLine) - { - strcpy(psdata->m_commandLine, cmdLineCopy); - psdata->m_fromConsole = TRUE; - - #ifdef MPK_ON + fnSetupNamespace(); + if (access(NWDEFPERLTEMP, 0) != 0) + mkdir(NWDEFPERLTEMP); + + // Create the file NUL if not present. This is done only once per NLM load. + // This is required for -e. + // Earlier versions were creating temporary files (in perl.c file) for -e. + // Now, the technique of creating temporary files are removed since they were + // fragile or insecure or slow. It now uses the memory by setting + // the BIT_BUCKET to "nul" on Win32, which is equivalent to /dev/nul of Unix. + // Since there is no equivalent of /dev/nul on NetWare, the work-around is that + // we create a file called "nul" and the BIT_BUCKET is set to "nul". + // This makes sure that -e works on NetWare too without the creation of temporary files + // in -e code in perl.c + { + char sNUL[MAX_DN_BYTES] = {'\0'}; + + strcpy(sNUL, NWDEFPERLROOT); + strcat(sNUL, "\\nwnul"); + if (access((const char *)sNUL, 0) != 0) + { + // The file, "nul" is not found and so create the file. + FILE *fp = NULL; + + fp = fopen((const char *)sNUL, (const char *)"w"); + fclose(fp); + } + } + + fnRegisterCommandLineHandler(); // Register the command line handler + SynchronizeStart(); // Restart the NLM startup process when using synchronization mode. + + fnGetPerlScreenName(sPerlScreenName); // Get the screen name. Done only once per NLM load. + + + // If the command line has two strings, then the first has to be "Perl" and the second is assumed + // to be a script to be run. If only one string (i.e., Perl) is input, then there is nothing to do! + // + if ((argc > 1) && getcmd(sysCmdLine)) + { + strcpy(cmdLineCopy, PERL_COMMAND_NAME); + strcat(cmdLineCopy, (char *)" "); // Space between the Perl Command and the input script name. + strcat(cmdLineCopy, sysCmdLine); // The command line parameters built into + + // Create a safe copy of the command line and pass it to the + // new thread for parsing. The new thread will be responsible + // to delete it when it is finished with it. + // + psdata = (ScriptData *) malloc(sizeof(ScriptData)); + if (psdata) + { + psdata->m_commandLine = NULL; + psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(psdata->m_commandLine) + { + strcpy(psdata->m_commandLine, cmdLineCopy); + psdata->m_fromConsole = TRUE; + + #ifdef MPK_ON // kStartThread((char *)"ConsoleHandlerThread", fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void *)psdata); - // Establish a new thread within a new thread group. - BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #else - // Start a new thread in its own thread group - BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #endif //MPK_ON - } - else - { - free(psdata); - psdata = NULL; - return; - } - } - else - return; - } - - - // Keep this thread alive, since we use the thread group id of this thread to allocate memory on. - // When we unload the NLM, clib will tear the thread down. - // - #ifdef MPK_ON - kSuspendThread(gThreadHandle); - #else - SuspendThread(GetThreadID()); - #endif //MPK_ON - - - return; + // Establish a new thread within a new thread group. + BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #else + // Start a new thread in its own thread group + BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #endif //MPK_ON + } + else + { + free(psdata); + psdata = NULL; + return; + } + } + else + return; + } + + + // Keep this thread alive, since we use the thread group id of this thread to allocate memory on. + // When we unload the NLM, clib will tear the thread down. + // + #ifdef MPK_ON + kSuspendThread(gThreadHandle); + #else + SuspendThread(GetThreadID()); + #endif //MPK_ON + + + return; } @@ -271,55 +271,55 @@ void main(int argc, char *argv[]) void fnSigTermHandler(int sig) { - int k = 0; - - - #ifdef MPK_ON - kResumeThread(gThreadHandle); - #endif //MPK_ON - - // Unregister the command line handler. - // - if (gCmdProcInit) - { - UnRegisterConsoleCommand (&gCmdParser); - gCmdProcInit = FALSE; - } - - // Free the global environ buffer - nw_freeenviron(); - - // Kill running scripts. - // - if (!fnTerminateThreadInfo()) - { - ConsolePrintf("Terminating Perl scripts...\n"); - gKillAll = TRUE; - - // fnTerminateThreadInfo will be run for 5 threads. If more threads/scripts are run, - // then the NLM will unload without terminating the thread info and leaks more memory. - // If this number is increased to reduce memory leaks, then it will unnecessarily take more time - // to unload when there are a smaller no of threads. Since this is a rare case, the no is kept as 5. - // - while (!fnTerminateThreadInfo() && k < 5) - { - nw_sleep(1); - k++; - } - } - - // Delete the file, "nul" if present since the NLM is unloaded. - { - char sNUL[MAX_DN_BYTES] = {'\0'}; - - strcpy(sNUL, NWDEFPERLROOT); - strcat(sNUL, "\\nwnul"); - if (access((const char *)sNUL, 0) == 0) - { - // The file, "nul" is found and so delete it. - unlink((const char *)sNUL); - } - } + int k = 0; + + + #ifdef MPK_ON + kResumeThread(gThreadHandle); + #endif //MPK_ON + + // Unregister the command line handler. + // + if (gCmdProcInit) + { + UnRegisterConsoleCommand (&gCmdParser); + gCmdProcInit = FALSE; + } + + // Free the global environ buffer + nw_freeenviron(); + + // Kill running scripts. + // + if (!fnTerminateThreadInfo()) + { + ConsolePrintf("Terminating Perl scripts...\n"); + gKillAll = TRUE; + + // fnTerminateThreadInfo will be run for 5 threads. If more threads/scripts are run, + // then the NLM will unload without terminating the thread info and leaks more memory. + // If this number is increased to reduce memory leaks, then it will unnecessarily take more time + // to unload when there are a smaller no of threads. Since this is a rare case, the no is kept as 5. + // + while (!fnTerminateThreadInfo() && k < 5) + { + nw_sleep(1); + k++; + } + } + + // Delete the file, "nul" if present since the NLM is unloaded. + { + char sNUL[MAX_DN_BYTES] = {'\0'}; + + strcpy(sNUL, NWDEFPERLROOT); + strcat(sNUL, "\\nwnul"); + if (access((const char *)sNUL, 0) == 0) + { + // The file, "nul" is found and so delete it. + unlink((const char *)sNUL); + } + } } @@ -329,12 +329,12 @@ void fnSigTermHandler(int sig) Function : fnCommandLineHandler Description : Gets called by OS when someone enters an unknown command at the system console, - after this routine is registered by RegisterConsoleCommand. - For the valid command we just spawn a thread with enough stack space - to actually run the script. + after this routine is registered by RegisterConsoleCommand. + For the valid command we just spawn a thread with enough stack space + to actually run the script. Parameters : screenID (IN) - id for the screen. - cmdLine (IN) - Command line string. + cmdLine (IN) - Command line string. Returns : Long. @@ -342,78 +342,78 @@ void fnSigTermHandler(int sig) LONG fnCommandLineHandler (LONG screenID, BYTE * cmdLine) { - ScriptData* psdata=NULL; - int OsThrdGrpID = -1; - LONG retCode = CS_CMD_FOUND; - char* cptr = NULL; - - - #ifdef MPK_ON - // Initialisation for MPK_ON - #else - OsThrdGrpID = -1; - #endif //MPK_ON - - - #ifdef MPK_ON - // For MPK_ON - #else - if (gThreadGroupID != -1) - OsThrdGrpID = SetThreadGroupID (gThreadGroupID); - #endif //MPK_ON - - - cptr = fnSkipWhite(cmdLine); // Skip white spaces. - if ((strnicmp(cptr, PERL_COMMAND_NAME, strlen(PERL_COMMAND_NAME)) == 0) && - ((cptr[strlen(PERL_COMMAND_NAME)] == ' ') || - (cptr[strlen(PERL_COMMAND_NAME)] == '\t') || - (cptr[strlen(PERL_COMMAND_NAME)] == '\0'))) - { - // Create a safe copy of the command line and pass it to the new thread for parsing. - // The new thread will be responsible to delete it when it is finished with it. - // - psdata = (ScriptData *) malloc(sizeof(ScriptData)); - if (psdata) - { - psdata->m_commandLine = NULL; - psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if(psdata->m_commandLine) - { - strcpy(psdata->m_commandLine, (char *)cmdLine); - psdata->m_fromConsole = TRUE; - - #ifdef MPK_ON + ScriptData* psdata=NULL; + int OsThrdGrpID = -1; + LONG retCode = CS_CMD_FOUND; + char* cptr = NULL; + + + #ifdef MPK_ON + // Initialisation for MPK_ON + #else + OsThrdGrpID = -1; + #endif //MPK_ON + + + #ifdef MPK_ON + // For MPK_ON + #else + if (gThreadGroupID != -1) + OsThrdGrpID = SetThreadGroupID (gThreadGroupID); + #endif //MPK_ON + + + cptr = fnSkipWhite(cmdLine); // Skip white spaces. + if ((strnicmp(cptr, PERL_COMMAND_NAME, strlen(PERL_COMMAND_NAME)) == 0) && + ((cptr[strlen(PERL_COMMAND_NAME)] == ' ') || + (cptr[strlen(PERL_COMMAND_NAME)] == '\t') || + (cptr[strlen(PERL_COMMAND_NAME)] == '\0'))) + { + // Create a safe copy of the command line and pass it to the new thread for parsing. + // The new thread will be responsible to delete it when it is finished with it. + // + psdata = (ScriptData *) malloc(sizeof(ScriptData)); + if (psdata) + { + psdata->m_commandLine = NULL; + psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if(psdata->m_commandLine) + { + strcpy(psdata->m_commandLine, (char *)cmdLine); + psdata->m_fromConsole = TRUE; + + #ifdef MPK_ON // kStartThread((char *)"ConsoleHandlerThread", fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void *)psdata); - // Establish a new thread within a new thread group. - BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #else - // Start a new thread in its own thread group - BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #endif //MPK_ON - } - else - { - free(psdata); - psdata = NULL; - retCode = CS_CMD_NOT_FOUND; - } - } - else - retCode = CS_CMD_NOT_FOUND; - } - else - retCode = CS_CMD_NOT_FOUND; - - - #ifdef MPK_ON - // For MPK_ON - #else - if (OsThrdGrpID != -1) - SetThreadGroupID (OsThrdGrpID); - #endif //MPK_ON - - - return retCode; + // Establish a new thread within a new thread group. + BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #else + // Start a new thread in its own thread group + BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #endif //MPK_ON + } + else + { + free(psdata); + psdata = NULL; + retCode = CS_CMD_NOT_FOUND; + } + } + else + retCode = CS_CMD_NOT_FOUND; + } + else + retCode = CS_CMD_NOT_FOUND; + + + #ifdef MPK_ON + // For MPK_ON + #else + if (OsThrdGrpID != -1) + SetThreadGroupID (OsThrdGrpID); + #endif //MPK_ON + + + return retCode; } @@ -432,16 +432,16 @@ LONG fnCommandLineHandler (LONG screenID, BYTE * cmdLine) void fnRegisterCommandLineHandler(void) { - // Allocates resource tag for Console Command - if ((gCmdParser.RTag = - AllocateResourceTag (GetNLMHandle(), (char *)"Console Command", ConsoleCommandSignature)) != 0) - { - gCmdParser.parseRoutine = fnCommandLineHandler; // Set the Console Command parsing routine. - RegisterConsoleCommand (&gCmdParser); // Registers the Console Command parsing function - gCmdProcInit = TRUE; - } - - return; + // Allocates resource tag for Console Command + if ((gCmdParser.RTag = + AllocateResourceTag (GetNLMHandle(), (char *)"Console Command", ConsoleCommandSignature)) != 0) + { + gCmdParser.parseRoutine = fnCommandLineHandler; // Set the Console Command parsing routine. + RegisterConsoleCommand (&gCmdParser); // Registers the Console Command parsing function + gCmdProcInit = TRUE; + } + + return; } @@ -460,44 +460,44 @@ void fnRegisterCommandLineHandler(void) void fnSetupNamespace(void) { - SetCurrentNameSpace(NWOS2_NAME_SPACE); + SetCurrentNameSpace(NWOS2_NAME_SPACE); - //LATER: call SetTargetNameSpace(NWOS2_NAME_SPACE)? Currently, if - // I make this call, then CPerlExe::Rename fails in certain cases, - // and it isn't clear why. Looks like a CLIB bug... + //LATER: call SetTargetNameSpace(NWOS2_NAME_SPACE)? Currently, if + // I make this call, then CPerlExe::Rename fails in certain cases, + // and it isn't clear why. Looks like a CLIB bug... // SetTargetNameSpace(NWOS2_NAME_SPACE); - //Uncommented that above call, retaining the comment so that it will be easy - //to revert back if there is any problem - sgp - 10th May 2000 - - //Commented again, since Perl debugger had some problems because of - //the above call - sgp - 20th June 2000 - - { - // if running on Moab, call UseAccurateCaseForPaths. This API - // does bad things on 4.11 so we call only for Moab. - PFGETFILESERVERMAJORVERSIONNUMBER pf_getfileservermajorversionnumber = NULL; - pf_getfileservermajorversionnumber = (PFGETFILESERVERMAJORVERSIONNUMBER) - ImportSymbol(GetNLMHandle(), (char *)"GetFileServerMajorVersionNumber"); - if (pf_getfileservermajorversionnumber && ((*pf_getfileservermajorversionnumber)() > 4)) - { - PFUSEACCURATECASEFORPATHS pf_useaccuratecaseforpaths = NULL; - pf_useaccuratecaseforpaths = (PFUSEACCURATECASEFORPATHS) - ImportSymbol(GetNLMHandle(), (char *)"UseAccurateCaseForPaths"); - if (pf_useaccuratecaseforpaths) - (*pf_useaccuratecaseforpaths)(TRUE); - { - PFUNAUGMENTASTERISK pf_unaugmentasterisk = NULL; - pf_unaugmentasterisk = (PFUNAUGMENTASTERISK) - ImportSymbol(GetNLMHandle(), (char *)"UnAugmentAsterisk"); - if (pf_unaugmentasterisk) - (*pf_unaugmentasterisk)(TRUE); - } - } - } - - return; + //Uncommented that above call, retaining the comment so that it will be easy + //to revert back if there is any problem - sgp - 10th May 2000 + + //Commented again, since Perl debugger had some problems because of + //the above call - sgp - 20th June 2000 + + { + // if running on Moab, call UseAccurateCaseForPaths. This API + // does bad things on 4.11 so we call only for Moab. + PFGETFILESERVERMAJORVERSIONNUMBER pf_getfileservermajorversionnumber = NULL; + pf_getfileservermajorversionnumber = (PFGETFILESERVERMAJORVERSIONNUMBER) + ImportSymbol(GetNLMHandle(), (char *)"GetFileServerMajorVersionNumber"); + if (pf_getfileservermajorversionnumber && ((*pf_getfileservermajorversionnumber)() > 4)) + { + PFUSEACCURATECASEFORPATHS pf_useaccuratecaseforpaths = NULL; + pf_useaccuratecaseforpaths = (PFUSEACCURATECASEFORPATHS) + ImportSymbol(GetNLMHandle(), (char *)"UseAccurateCaseForPaths"); + if (pf_useaccuratecaseforpaths) + (*pf_useaccuratecaseforpaths)(TRUE); + { + PFUNAUGMENTASTERISK pf_unaugmentasterisk = NULL; + pf_unaugmentasterisk = (PFUNAUGMENTASTERISK) + ImportSymbol(GetNLMHandle(), (char *)"UnAugmentAsterisk"); + if (pf_unaugmentasterisk) + (*pf_unaugmentasterisk)(TRUE); + } + } + } + + return; } @@ -516,94 +516,94 @@ void fnSetupNamespace(void) void fnLaunchPerl(void* context) { - char* defaultDir = NULL; - char curdir[_MAX_PATH] = {'\0'}; - ScriptData* psdata = (ScriptData *) context; - - unsigned int moduleHandle = 0; - int currentThreadGroupID = -1; - - #ifdef MPK_ON - kExitNetWare(); - #endif //MPK_ON - - errno = 0; - - if (psdata->m_fromConsole) - { - // get the default working directory name - // - defaultDir = fnNwGetEnvironmentStr("PERL_ROOT", NWDEFPERLROOT); - } - else - defaultDir = getcwd(curdir, sizeof(curdir)-1); - - // set long name space - // - fnSetupNamespace(); - - // make the working directory the current directory if from console - // - if (psdata->m_fromConsole) - chdir(defaultDir); - - // run the script - // - fnRunScript(psdata); - - // May have to check this, I am blindly calling UCSTerminate, irrespective of - // whether it is initialized or not - // Copied from the previous Perl - sgp - 31st Oct 2000 - moduleHandle = FindNLMHandle("UCSCORE.NLM"); - if (moduleHandle) - { - PFUCSTERMINATE ucsterminate = (PFUCSTERMINATE)ImportSymbol(moduleHandle, "therealUCSTerminate"); - if (ucsterminate!=NULL) - (*ucsterminate)(); - } - - if (psdata->m_fromConsole) - { - // change thread groups for the call to free the memory - // allocated before the new thread group was started - #ifdef MPK_ON - // For MPK_ON - #else - if (gThreadGroupID != -1) - currentThreadGroupID = SetThreadGroupID (gThreadGroupID); - #endif //MPK_ON - } - - // Free memory - if (psdata) - { - if(psdata->m_commandLine) - { - free(psdata->m_commandLine); - psdata->m_commandLine = NULL; - } - - free(psdata); - psdata = NULL; - context = NULL; - } - - #ifdef MPK_ON - // For MPK_ON - #else - if (currentThreadGroupID != -1) - SetThreadGroupID (currentThreadGroupID); - #endif //MPK_ON - - #ifdef MPK_ON + char* defaultDir = NULL; + char curdir[_MAX_PATH] = {'\0'}; + ScriptData* psdata = (ScriptData *) context; + + unsigned int moduleHandle = 0; + int currentThreadGroupID = -1; + + #ifdef MPK_ON + kExitNetWare(); + #endif //MPK_ON + + errno = 0; + + if (psdata->m_fromConsole) + { + // get the default working directory name + // + defaultDir = fnNwGetEnvironmentStr("PERL_ROOT", NWDEFPERLROOT); + } + else + defaultDir = getcwd(curdir, sizeof(curdir)-1); + + // set long name space + // + fnSetupNamespace(); + + // make the working directory the current directory if from console + // + if (psdata->m_fromConsole) + chdir(defaultDir); + + // run the script + // + fnRunScript(psdata); + + // May have to check this, I am blindly calling UCSTerminate, irrespective of + // whether it is initialized or not + // Copied from the previous Perl - sgp - 31st Oct 2000 + moduleHandle = FindNLMHandle("UCSCORE.NLM"); + if (moduleHandle) + { + PFUCSTERMINATE ucsterminate = (PFUCSTERMINATE)ImportSymbol(moduleHandle, "therealUCSTerminate"); + if (ucsterminate!=NULL) + (*ucsterminate)(); + } + + if (psdata->m_fromConsole) + { + // change thread groups for the call to free the memory + // allocated before the new thread group was started + #ifdef MPK_ON + // For MPK_ON + #else + if (gThreadGroupID != -1) + currentThreadGroupID = SetThreadGroupID (gThreadGroupID); + #endif //MPK_ON + } + + // Free memory + if (psdata) + { + if(psdata->m_commandLine) + { + free(psdata->m_commandLine); + psdata->m_commandLine = NULL; + } + + free(psdata); + psdata = NULL; + context = NULL; + } + + #ifdef MPK_ON + // For MPK_ON + #else + if (currentThreadGroupID != -1) + SetThreadGroupID (currentThreadGroupID); + #endif //MPK_ON + + #ifdef MPK_ON // kExitThread(NULL); - #else - // just let the thread terminate by falling off the end of the - // function started by BeginThreadGroup + #else + // just let the thread terminate by falling off the end of the + // function started by BeginThreadGroup // ExitThread(EXIT_THREAD, 0); - #endif + #endif - return; + return; } @@ -622,459 +622,459 @@ void fnLaunchPerl(void* context) void fnRunScript(ScriptData* psdata) { - char **av=NULL; - char **en=NULL; - int exitstatus = 1; - int i=0, j=0; - int *dummy = 0; - - PCOMMANDLINEPARSER pclp = NULL; - - // Set up the environment block. This will only work on - // on Moab; on 4.11 the environment block will be empty. - char** env = NULL; - - BOOL use_system_console = TRUE; - BOOL newscreen = FALSE; - int newscreenhandle = 0; - - // redirect stdin or stdout and run the script - FILE* redirOut = NULL; - FILE* redirIn = NULL; - FILE* redirErr = NULL; - FILE* stderr_fp = NULL; - - int stdin_fd=-1, stdin_fd_dup=-1; - int stdout_fd=-1, stdout_fd_dup=-1; - int stderr_fd=-1, stderr_fd_dup=-1; - - - // Main callback instance - // - if (fnRegisterWithThreadTable() == FALSE) - return; - - // parse the command line into argc/argv style: - // number of params and char array of params - // - pclp = (PCOMMANDLINEPARSER) malloc(sizeof(COMMANDLINEPARSER)); - if (!pclp) - { - fnUnregisterWithThreadTable(); - return; - } - - // Initialise the variables - pclp->m_isValid = TRUE; - pclp->m_redirInName = NULL; - pclp->m_redirOutName = NULL; - pclp->m_redirErrName = NULL; - pclp->m_redirBothName = NULL; - pclp->nextarg = NULL; - pclp->sSkippedToken = NULL; - pclp->m_argv = NULL; - pclp->new_argv = NULL; - - #ifdef MPK_ON - pclp->m_qSemaphore = NULL; - #else - pclp->m_qSemaphore = 0L; - #endif //MPK_ON - - pclp->m_noScreen = 0; - pclp->m_AutoDestroy = 0; - pclp->m_argc = 0; - pclp->m_argv_len = 1; - - // Allocate memory - pclp->m_argv = (char **) malloc(pclp->m_argv_len * sizeof(char *)); - if (pclp->m_argv == NULL) - { - free(pclp); - pclp = NULL; - - fnUnregisterWithThreadTable(); - return; - } - - pclp->m_argv[0] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if (pclp->m_argv[0] == NULL) - { - free(pclp->m_argv); - pclp->m_argv=NULL; - - free(pclp); - pclp = NULL; - - fnUnregisterWithThreadTable(); - return; - } - - // Parse the command line - fnCommandLineParser(pclp, (char *)psdata->m_commandLine, FALSE); - if (!pclp->m_isValid) - { - if(pclp->m_argv) - { - for(i=0; i<pclp->m_argv_len; i++) - { - if(pclp->m_argv[i] != NULL) - { - free(pclp->m_argv[i]); - pclp->m_argv[i] = NULL; - } - } - - free(pclp->m_argv); - pclp->m_argv = NULL; - } - - if(pclp->nextarg) - { - free(pclp->nextarg); - pclp->nextarg = NULL; - } - if(pclp->sSkippedToken != NULL) - { - free(pclp->sSkippedToken); - pclp->sSkippedToken = NULL; - } - - if(pclp->m_redirInName) - { - free(pclp->m_redirInName); - pclp->m_redirInName = NULL; - } - if(pclp->m_redirOutName) - { - free(pclp->m_redirOutName); - pclp->m_redirOutName = NULL; - } - if(pclp->m_redirErrName) - { - free(pclp->m_redirErrName); - pclp->m_redirErrName = NULL; - } - if(pclp->m_redirBothName) - { - free(pclp->m_redirBothName); - pclp->m_redirBothName = NULL; - } - - // Signal a semaphore, if indicated by "-{" option, to indicate that - // the script has terminated and files are closed - // - if (pclp->m_qSemaphore != 0) - { - #ifdef MPK_ON - kSemaphoreSignal(pclp->m_qSemaphore); - #else - SignalLocalSemaphore(pclp->m_qSemaphore); - #endif //MPK_ON - } - - free(pclp); - pclp = NULL; - - fnUnregisterWithThreadTable(); - return; - } - - // Simulating a shell on NetWare can be difficult. If you don't - // create a new screen for the script to run in, you can output to - // the console but you can't get any input from the console. Therefore, - // every invocation of perl potentially needs its own screen unless - // you are running either "perl -h" or "perl -v" or you are redirecting - // stdin from a file. - // - // So we need to create a new screen and set that screen as the current - // screen when running any script launched from the console that is not - // "perl -h" or "perl -v" and is not redirecting stdin from a file. - // - // But it would be a little weird if we didn't create a new screen only - // in the case when redirecting stdin from a file; in only that case, - // stdout would be the console instead of a new screen. - // - // There is also the issue of standard err. In short, we might as well - // create a new screen no matter what is going on with redirection, just - // for the sake of consistency. - // - // In summary, we should a create a new screen and make that screen the - // current screen unless one of the following is true: - // * The command is "perl -h" - // * The command is "perl -v" - // * The script was launched by another perl script. In this case, - // the screen belonging to the parent perl script should probably be - // the same screen for this process. And it will be if use BeginThread - // instead of BeginThreadGroup when launching Perl from within a Perl - // script. - // - // In those cases where we create a new screen we should probably also display - // that screen. - // - - use_system_console = pclp->m_noScreen || - ((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-h") == 0)) || - ((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-v") == 0)); - - newscreen = (!use_system_console) && psdata->m_fromConsole; - - if (newscreen) - { - newscreenhandle = CreateScreen(sPerlScreenName, 0); - if (newscreenhandle) - DisplayScreen(newscreenhandle); - } - else if (use_system_console) - CreateScreen((char *)"System Console", 0); - - if (pclp->m_redirInName) - { - if ((stdin_fd = fileno(stdin)) != -1) - { - stdin_fd_dup = dup(stdin_fd); - if (stdin_fd_dup != -1) - { - redirIn = fdopen (stdin_fd_dup, (char const *)"r"); - if (redirIn) - stdin = freopen (pclp->m_redirInName, (char const *)"r", redirIn); - if (!stdin) - { - redirIn = NULL; - // undo the redirect, if possible - stdin = fdopen(stdin_fd, (char const *)"r"); - } - } - } - } - - /** - The below code stores the handle for the existing stdout to be used later and the existing stdout is closed. - stdout is then initialised to the new File pointer where the operations are done onto that. - Later (look below for the code), the saved stdout is restored back. - **/ - if (pclp->m_redirOutName) - { - if ((stdout_fd = fileno(stdout)) != -1) // Handle of the existing stdout. - { - stdout_fd_dup = dup(stdout_fd); - if (stdout_fd_dup != -1) - { - // Close the existing stdout. - fflush(stdout); // Write any unwritten data to the file. - - // New stdout - redirOut = fdopen (stdout_fd_dup, (char const *)"w"); - if (redirOut) - stdout = freopen (pclp->m_redirOutName, (char const *)"w", redirOut); - if (!stdout) - { - redirOut = NULL; - // Undo the redirection. - stdout = fdopen(stdout_fd, (char const *)"w"); - } - setbuf(stdout, NULL); // Unbuffered file pointer. - } - } - } - - if (pclp->m_redirErrName) - { - if ((stderr_fd = fileno(stderr)) != -1) - { - stderr_fd_dup = dup(stderr_fd); - if (stderr_fd_dup != -1) - { - fflush(stderr); - - redirErr = fdopen (stderr_fd_dup, (char const *)"w"); - if (redirErr) - stderr = freopen (pclp->m_redirErrName, (char const *)"w", redirErr); - if (!stderr) - { - redirErr = NULL; - // undo the redirect, if possible - stderr = fdopen(stderr_fd, (char const *)"w"); - } - setbuf(stderr, NULL); // Unbuffered file pointer. - } - } - } - - if (pclp->m_redirBothName) - { - if ((stdout_fd = fileno(stdout)) != -1) - { - stdout_fd_dup = dup(stdout_fd); - if (stdout_fd_dup != -1) - { - fflush(stdout); - - redirOut = fdopen (stdout_fd_dup, (char const *)"w"); - if (redirOut) - stdout = freopen (pclp->m_redirBothName, (char const *)"w", redirOut); - if (!stdout) - { - redirOut = NULL; - // undo the redirect, if possible - stdout = fdopen(stdout_fd, (char const *)"w"); - } - setbuf(stdout, NULL); // Unbuffered file pointer. - } - } - if ((stderr_fd = fileno(stderr)) != -1) - { - stderr_fp = stderr; - stderr = stdout; - } - } - - env = NULL; - fnSetUpEnvBlock(&env); // Set up the ENV block - - // Run the Perl script - exitstatus = RunPerl(pclp->m_argc, pclp->m_argv, env); - - // clean up any redirection - // - if (pclp->m_redirInName && redirIn) - { - fclose(stdin); - stdin = fdopen(stdin_fd, (char const *)"r"); // Put back the old handle for stdin. - } - - if (pclp->m_redirOutName && redirOut) - { - // Close the new stdout. - fflush(stdout); - fclose(stdout); - - // Put back the old handle for stdout. - stdout = fdopen(stdout_fd, (char const *)"w"); - setbuf(stdout, NULL); // Unbuffered file pointer. - } - - if (pclp->m_redirErrName && redirErr) - { - fflush(stderr); - fclose(stderr); - - stderr = fdopen(stderr_fd, (char const *)"w"); // Put back the old handle for stderr. - setbuf(stderr, NULL); // Unbuffered file pointer. - } - - if (pclp->m_redirBothName && redirOut) - { - stderr = stderr_fp; - - fflush(stdout); - fclose(stdout); - - stdout = fdopen(stdout_fd, (char const *)"w"); // Put back the old handle for stdout. - setbuf(stdout, NULL); // Unbuffered file pointer. - } - - - if (newscreen && newscreenhandle) - { - //added for --autodestroy switch - if(!pclp->m_AutoDestroy) - { - if ((redirOut == NULL) && (redirIn == NULL) && (!gKillAll)) - { - printf((char *)"\n\nPress any key to exit\n"); - getch(); - } - } - DestroyScreen(newscreenhandle); - } + char **av=NULL; + char **en=NULL; + int exitstatus = 1; + int i=0, j=0; + int *dummy = 0; + + PCOMMANDLINEPARSER pclp = NULL; + + // Set up the environment block. This will only work on + // on Moab; on 4.11 the environment block will be empty. + char** env = NULL; + + BOOL use_system_console = TRUE; + BOOL newscreen = FALSE; + int newscreenhandle = 0; + + // redirect stdin or stdout and run the script + FILE* redirOut = NULL; + FILE* redirIn = NULL; + FILE* redirErr = NULL; + FILE* stderr_fp = NULL; + + int stdin_fd=-1, stdin_fd_dup=-1; + int stdout_fd=-1, stdout_fd_dup=-1; + int stderr_fd=-1, stderr_fd_dup=-1; + + + // Main callback instance + // + if (fnRegisterWithThreadTable() == FALSE) + return; + + // parse the command line into argc/argv style: + // number of params and char array of params + // + pclp = (PCOMMANDLINEPARSER) malloc(sizeof(COMMANDLINEPARSER)); + if (!pclp) + { + fnUnregisterWithThreadTable(); + return; + } + + // Initialise the variables + pclp->m_isValid = TRUE; + pclp->m_redirInName = NULL; + pclp->m_redirOutName = NULL; + pclp->m_redirErrName = NULL; + pclp->m_redirBothName = NULL; + pclp->nextarg = NULL; + pclp->sSkippedToken = NULL; + pclp->m_argv = NULL; + pclp->new_argv = NULL; + + #ifdef MPK_ON + pclp->m_qSemaphore = NULL; + #else + pclp->m_qSemaphore = 0L; + #endif //MPK_ON + + pclp->m_noScreen = 0; + pclp->m_AutoDestroy = 0; + pclp->m_argc = 0; + pclp->m_argv_len = 1; + + // Allocate memory + pclp->m_argv = (char **) malloc(pclp->m_argv_len * sizeof(char *)); + if (pclp->m_argv == NULL) + { + free(pclp); + pclp = NULL; + + fnUnregisterWithThreadTable(); + return; + } + + pclp->m_argv[0] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if (pclp->m_argv[0] == NULL) + { + free(pclp->m_argv); + pclp->m_argv=NULL; + + free(pclp); + pclp = NULL; + + fnUnregisterWithThreadTable(); + return; + } + + // Parse the command line + fnCommandLineParser(pclp, (char *)psdata->m_commandLine, FALSE); + if (!pclp->m_isValid) + { + if(pclp->m_argv) + { + for(i=0; i<pclp->m_argv_len; i++) + { + if(pclp->m_argv[i] != NULL) + { + free(pclp->m_argv[i]); + pclp->m_argv[i] = NULL; + } + } + + free(pclp->m_argv); + pclp->m_argv = NULL; + } + + if(pclp->nextarg) + { + free(pclp->nextarg); + pclp->nextarg = NULL; + } + if(pclp->sSkippedToken != NULL) + { + free(pclp->sSkippedToken); + pclp->sSkippedToken = NULL; + } + + if(pclp->m_redirInName) + { + free(pclp->m_redirInName); + pclp->m_redirInName = NULL; + } + if(pclp->m_redirOutName) + { + free(pclp->m_redirOutName); + pclp->m_redirOutName = NULL; + } + if(pclp->m_redirErrName) + { + free(pclp->m_redirErrName); + pclp->m_redirErrName = NULL; + } + if(pclp->m_redirBothName) + { + free(pclp->m_redirBothName); + pclp->m_redirBothName = NULL; + } + + // Signal a semaphore, if indicated by "-{" option, to indicate that + // the script has terminated and files are closed + // + if (pclp->m_qSemaphore != 0) + { + #ifdef MPK_ON + kSemaphoreSignal(pclp->m_qSemaphore); + #else + SignalLocalSemaphore(pclp->m_qSemaphore); + #endif //MPK_ON + } + + free(pclp); + pclp = NULL; + + fnUnregisterWithThreadTable(); + return; + } + + // Simulating a shell on NetWare can be difficult. If you don't + // create a new screen for the script to run in, you can output to + // the console but you can't get any input from the console. Therefore, + // every invocation of perl potentially needs its own screen unless + // you are running either "perl -h" or "perl -v" or you are redirecting + // stdin from a file. + // + // So we need to create a new screen and set that screen as the current + // screen when running any script launched from the console that is not + // "perl -h" or "perl -v" and is not redirecting stdin from a file. + // + // But it would be a little weird if we didn't create a new screen only + // in the case when redirecting stdin from a file; in only that case, + // stdout would be the console instead of a new screen. + // + // There is also the issue of standard err. In short, we might as well + // create a new screen no matter what is going on with redirection, just + // for the sake of consistency. + // + // In summary, we should a create a new screen and make that screen the + // current screen unless one of the following is true: + // * The command is "perl -h" + // * The command is "perl -v" + // * The script was launched by another perl script. In this case, + // the screen belonging to the parent perl script should probably be + // the same screen for this process. And it will be if use BeginThread + // instead of BeginThreadGroup when launching Perl from within a Perl + // script. + // + // In those cases where we create a new screen we should probably also display + // that screen. + // + + use_system_console = pclp->m_noScreen || + ((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-h") == 0)) || + ((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-v") == 0)); + + newscreen = (!use_system_console) && psdata->m_fromConsole; + + if (newscreen) + { + newscreenhandle = CreateScreen(sPerlScreenName, 0); + if (newscreenhandle) + DisplayScreen(newscreenhandle); + } + else if (use_system_console) + CreateScreen((char *)"System Console", 0); + + if (pclp->m_redirInName) + { + if ((stdin_fd = fileno(stdin)) != -1) + { + stdin_fd_dup = dup(stdin_fd); + if (stdin_fd_dup != -1) + { + redirIn = fdopen (stdin_fd_dup, (char const *)"r"); + if (redirIn) + stdin = freopen (pclp->m_redirInName, (char const *)"r", redirIn); + if (!stdin) + { + redirIn = NULL; + // undo the redirect, if possible + stdin = fdopen(stdin_fd, (char const *)"r"); + } + } + } + } + + /** + The below code stores the handle for the existing stdout to be used later and the existing stdout is closed. + stdout is then initialised to the new File pointer where the operations are done onto that. + Later (look below for the code), the saved stdout is restored back. + **/ + if (pclp->m_redirOutName) + { + if ((stdout_fd = fileno(stdout)) != -1) // Handle of the existing stdout. + { + stdout_fd_dup = dup(stdout_fd); + if (stdout_fd_dup != -1) + { + // Close the existing stdout. + fflush(stdout); // Write any unwritten data to the file. + + // New stdout + redirOut = fdopen (stdout_fd_dup, (char const *)"w"); + if (redirOut) + stdout = freopen (pclp->m_redirOutName, (char const *)"w", redirOut); + if (!stdout) + { + redirOut = NULL; + // Undo the redirection. + stdout = fdopen(stdout_fd, (char const *)"w"); + } + setbuf(stdout, NULL); // Unbuffered file pointer. + } + } + } + + if (pclp->m_redirErrName) + { + if ((stderr_fd = fileno(stderr)) != -1) + { + stderr_fd_dup = dup(stderr_fd); + if (stderr_fd_dup != -1) + { + fflush(stderr); + + redirErr = fdopen (stderr_fd_dup, (char const *)"w"); + if (redirErr) + stderr = freopen (pclp->m_redirErrName, (char const *)"w", redirErr); + if (!stderr) + { + redirErr = NULL; + // undo the redirect, if possible + stderr = fdopen(stderr_fd, (char const *)"w"); + } + setbuf(stderr, NULL); // Unbuffered file pointer. + } + } + } + + if (pclp->m_redirBothName) + { + if ((stdout_fd = fileno(stdout)) != -1) + { + stdout_fd_dup = dup(stdout_fd); + if (stdout_fd_dup != -1) + { + fflush(stdout); + + redirOut = fdopen (stdout_fd_dup, (char const *)"w"); + if (redirOut) + stdout = freopen (pclp->m_redirBothName, (char const *)"w", redirOut); + if (!stdout) + { + redirOut = NULL; + // undo the redirect, if possible + stdout = fdopen(stdout_fd, (char const *)"w"); + } + setbuf(stdout, NULL); // Unbuffered file pointer. + } + } + if ((stderr_fd = fileno(stderr)) != -1) + { + stderr_fp = stderr; + stderr = stdout; + } + } + + env = NULL; + fnSetUpEnvBlock(&env); // Set up the ENV block + + // Run the Perl script + exitstatus = RunPerl(pclp->m_argc, pclp->m_argv, env); + + // clean up any redirection + // + if (pclp->m_redirInName && redirIn) + { + fclose(stdin); + stdin = fdopen(stdin_fd, (char const *)"r"); // Put back the old handle for stdin. + } + + if (pclp->m_redirOutName && redirOut) + { + // Close the new stdout. + fflush(stdout); + fclose(stdout); + + // Put back the old handle for stdout. + stdout = fdopen(stdout_fd, (char const *)"w"); + setbuf(stdout, NULL); // Unbuffered file pointer. + } + + if (pclp->m_redirErrName && redirErr) + { + fflush(stderr); + fclose(stderr); + + stderr = fdopen(stderr_fd, (char const *)"w"); // Put back the old handle for stderr. + setbuf(stderr, NULL); // Unbuffered file pointer. + } + + if (pclp->m_redirBothName && redirOut) + { + stderr = stderr_fp; + + fflush(stdout); + fclose(stdout); + + stdout = fdopen(stdout_fd, (char const *)"w"); // Put back the old handle for stdout. + setbuf(stdout, NULL); // Unbuffered file pointer. + } + + + if (newscreen && newscreenhandle) + { + //added for --autodestroy switch + if(!pclp->m_AutoDestroy) + { + if ((redirOut == NULL) && (redirIn == NULL) && (!gKillAll)) + { + printf((char *)"\n\nPress any key to exit\n"); + getch(); + } + } + DestroyScreen(newscreenhandle); + } /** - // Commented since a few abends were happening in fnFpSetMode - // Set the mode for stdin and stdout - fnFpSetMode(stdin, O_TEXT, dummy); - fnFpSetMode(stdout, O_TEXT, dummy); + // Commented since a few abends were happening in fnFpSetMode + // Set the mode for stdin and stdout + fnFpSetMode(stdin, O_TEXT, dummy); + fnFpSetMode(stdout, O_TEXT, dummy); **/ - setmode(stdin, O_TEXT); - setmode(stdout, O_TEXT); - - // Cleanup - if(pclp->m_argv) - { - for(i=0; i<pclp->m_argv_len; i++) - { - if(pclp->m_argv[i] != NULL) - { - free(pclp->m_argv[i]); - pclp->m_argv[i] = NULL; - } - } - - free(pclp->m_argv); - pclp->m_argv = NULL; - } - - if(pclp->nextarg) - { - free(pclp->nextarg); - pclp->nextarg = NULL; - } - if(pclp->sSkippedToken != NULL) - { - free(pclp->sSkippedToken); - pclp->sSkippedToken = NULL; - } - - if(pclp->m_redirInName) - { - free(pclp->m_redirInName); - pclp->m_redirInName = NULL; - } - if(pclp->m_redirOutName) - { - free(pclp->m_redirOutName); - pclp->m_redirOutName = NULL; - } - if(pclp->m_redirErrName) - { - free(pclp->m_redirErrName); - pclp->m_redirErrName = NULL; - } - if(pclp->m_redirBothName) - { - free(pclp->m_redirBothName); - pclp->m_redirBothName = NULL; - } - - // Signal a semaphore, if indicated by -{ option, to indicate that - // the script has terminated and files are closed - // - if (pclp->m_qSemaphore != 0) - { - #ifdef MPK_ON - kSemaphoreSignal(pclp->m_qSemaphore); - #else - SignalLocalSemaphore(pclp->m_qSemaphore); - #endif //MPK_ON - } - - if(pclp) - { - free(pclp); - pclp = NULL; - } - - if(env) - { - fnDestroyEnvBlock(env); - env = NULL; - } - - fnUnregisterWithThreadTable(); - // Remove the thread context set during Perl_set_context - Remove_Thread_Ctx(); - - return; + setmode(stdin, O_TEXT); + setmode(stdout, O_TEXT); + + // Cleanup + if(pclp->m_argv) + { + for(i=0; i<pclp->m_argv_len; i++) + { + if(pclp->m_argv[i] != NULL) + { + free(pclp->m_argv[i]); + pclp->m_argv[i] = NULL; + } + } + + free(pclp->m_argv); + pclp->m_argv = NULL; + } + + if(pclp->nextarg) + { + free(pclp->nextarg); + pclp->nextarg = NULL; + } + if(pclp->sSkippedToken != NULL) + { + free(pclp->sSkippedToken); + pclp->sSkippedToken = NULL; + } + + if(pclp->m_redirInName) + { + free(pclp->m_redirInName); + pclp->m_redirInName = NULL; + } + if(pclp->m_redirOutName) + { + free(pclp->m_redirOutName); + pclp->m_redirOutName = NULL; + } + if(pclp->m_redirErrName) + { + free(pclp->m_redirErrName); + pclp->m_redirErrName = NULL; + } + if(pclp->m_redirBothName) + { + free(pclp->m_redirBothName); + pclp->m_redirBothName = NULL; + } + + // Signal a semaphore, if indicated by -{ option, to indicate that + // the script has terminated and files are closed + // + if (pclp->m_qSemaphore != 0) + { + #ifdef MPK_ON + kSemaphoreSignal(pclp->m_qSemaphore); + #else + SignalLocalSemaphore(pclp->m_qSemaphore); + #endif //MPK_ON + } + + if(pclp) + { + free(pclp); + pclp = NULL; + } + + if(env) + { + fnDestroyEnvBlock(env); + env = NULL; + } + + fnUnregisterWithThreadTable(); + // Remove the thread context set during Perl_set_context + Remove_Thread_Ctx(); + + return; } @@ -1093,74 +1093,74 @@ void fnRunScript(ScriptData* psdata) void fnSetUpEnvBlock(char*** penv) { - char** env = NULL; - - int sequence = 0; - char var[kMaxVariableNameLen+1] = {'\0'}; - char val[kMaxValueLen+1] = {'\0'}; - char both[kMaxVariableNameLen + kMaxValueLen + 5] = {'\0'}; - size_t len = kMaxValueLen; - int totalcnt = 0; - - while(scanenv( &sequence, var, &len, val )) - { - totalcnt++; - len = kMaxValueLen; - } - // add one for null termination - totalcnt++; - - env = (char **) malloc (totalcnt * sizeof(char *)); - if (env) - { - int cnt = 0; - int i = 0; - - sequence = 0; - len = kMaxValueLen; - - while( (cnt < (totalcnt-1)) && scanenv( &sequence, var, &len, val ) ) - { - val[len] = '\0'; - strcpy( both, var ); - strcat( both, (char *)"=" ); - strcat( both, val ); - - env[cnt] = (char *) malloc((sizeof(both)+1) * sizeof(char)); - if (env[cnt]) - { - strcpy(env[cnt], both); - cnt++; - } - else - { - for(i=0; i<cnt; i++) - { - if(env[i]) - { - free(env[i]); - env[i] = NULL; - } - } - - free(env); - env = NULL; - - return; - } - - len = kMaxValueLen; - } - - for(i=cnt; i<=(totalcnt-1); i++) - env[i] = NULL; - } - else - return; - - *penv = env; - - return; + char** env = NULL; + + int sequence = 0; + char var[kMaxVariableNameLen+1] = {'\0'}; + char val[kMaxValueLen+1] = {'\0'}; + char both[kMaxVariableNameLen + kMaxValueLen + 5] = {'\0'}; + size_t len = kMaxValueLen; + int totalcnt = 0; + + while(scanenv( &sequence, var, &len, val )) + { + totalcnt++; + len = kMaxValueLen; + } + // add one for null termination + totalcnt++; + + env = (char **) malloc (totalcnt * sizeof(char *)); + if (env) + { + int cnt = 0; + int i = 0; + + sequence = 0; + len = kMaxValueLen; + + while( (cnt < (totalcnt-1)) && scanenv( &sequence, var, &len, val ) ) + { + val[len] = '\0'; + strcpy( both, var ); + strcat( both, (char *)"=" ); + strcat( both, val ); + + env[cnt] = (char *) malloc((sizeof(both)+1) * sizeof(char)); + if (env[cnt]) + { + strcpy(env[cnt], both); + cnt++; + } + else + { + for(i=0; i<cnt; i++) + { + if(env[i]) + { + free(env[i]); + env[i] = NULL; + } + } + + free(env); + env = NULL; + + return; + } + + len = kMaxValueLen; + } + + for(i=cnt; i<=(totalcnt-1); i++) + env[i] = NULL; + } + else + return; + + *penv = env; + + return; } @@ -1179,21 +1179,21 @@ void fnSetUpEnvBlock(char*** penv) void fnDestroyEnvBlock(char** env) { - // It is assumed that this block is entered only if env is TRUE. So, the calling function - // must check for this condition before calling fnDestroyEnvBlock. - // If no check is made by the calling function, then the server abends. - int k = 0; - while (env[k] != NULL) - { - free(env[k]); - env[k] = NULL; - k++; - } - - free(env); - env = NULL; - - return; + // It is assumed that this block is entered only if env is TRUE. So, the calling function + // must check for this condition before calling fnDestroyEnvBlock. + // If no check is made by the calling function, then the server abends. + int k = 0; + while (env[k] != NULL) + { + free(env[k]); + env[k] = NULL; + k++; + } + + free(env); + env = NULL; + + return; } @@ -1205,8 +1205,8 @@ void fnDestroyEnvBlock(char** env) Description : Sets the mode for a file. Parameters : fp (IN) - FILE pointer for the input file. - mode (IN) - Mode to be set - e (OUT) - Error. + mode (IN) - Mode to be set + e (OUT) - Error. Returns : Integer which is the set value. @@ -1214,44 +1214,44 @@ void fnDestroyEnvBlock(char** env) int fnFpSetMode(FILE* fp, int mode, int *err) { - int ret = -1; - - PFFSETMODE pf_fsetmode; - - if (mode == O_BINARY || mode == O_TEXT) - { - if (fp) - { - errno = 0; - // the setmode call is not implemented (correctly) on NetWare, - // but the CLIB guys were kind enough to provide another - // call, fsetmode, which does a similar thing. It only works - // on Moab - pf_fsetmode = (PFFSETMODE) ImportSymbol(GetNLMHandle(), (char *)"fsetmode"); - if (pf_fsetmode) - ret = (*pf_fsetmode) (fp, ((mode == O_BINARY) ? "b" : "t")); - else - { - // we are on 4.11 instead of Moab, so we just return an error - errno = ESERVER; - err = &errno; - } - if (errno) - err = &errno; - } - else - { - errno = EBADF; - err = &errno; - } - } - else - { - errno = EINVAL; - err = &errno; - } - - return ret; + int ret = -1; + + PFFSETMODE pf_fsetmode; + + if (mode == O_BINARY || mode == O_TEXT) + { + if (fp) + { + errno = 0; + // the setmode call is not implemented (correctly) on NetWare, + // but the CLIB guys were kind enough to provide another + // call, fsetmode, which does a similar thing. It only works + // on Moab + pf_fsetmode = (PFFSETMODE) ImportSymbol(GetNLMHandle(), (char *)"fsetmode"); + if (pf_fsetmode) + ret = (*pf_fsetmode) (fp, ((mode == O_BINARY) ? "b" : "t")); + else + { + // we are on 4.11 instead of Moab, so we just return an error + errno = ESERVER; + err = &errno; + } + if (errno) + err = &errno; + } + else + { + errno = EBADF; + err = &errno; + } + } + else + { + errno = EINVAL; + err = &errno; + } + + return ret; } @@ -1270,42 +1270,42 @@ int fnFpSetMode(FILE* fp, int mode, int *err) void fnInternalPerlLaunchHandler(char* cmdLine) { - int currentThreadGroup = -1; - - ScriptData* psdata=NULL; - - // Create a safe copy of the command line and pass it to the - // new thread for parsing. The new thread will be responsible - // to delete it when it is finished with it. - psdata = (ScriptData *) malloc(sizeof(ScriptData)); - if (psdata) - { - psdata->m_commandLine = NULL; - psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - - if(psdata->m_commandLine) - { - strcpy(psdata->m_commandLine, cmdLine); - psdata->m_fromConsole = FALSE; - - #ifdef MPK_ON - BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #else - // Start a new thread in its own thread group - BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); - #endif //MPK_ON - } - else - { - free(psdata); - psdata = NULL; - return; - } - } - else - return; - - return; + int currentThreadGroup = -1; + + ScriptData* psdata=NULL; + + // Create a safe copy of the command line and pass it to the + // new thread for parsing. The new thread will be responsible + // to delete it when it is finished with it. + psdata = (ScriptData *) malloc(sizeof(ScriptData)); + if (psdata) + { + psdata->m_commandLine = NULL; + psdata->m_commandLine = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + + if(psdata->m_commandLine) + { + strcpy(psdata->m_commandLine, cmdLine); + psdata->m_fromConsole = FALSE; + + #ifdef MPK_ON + BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #else + // Start a new thread in its own thread group + BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata); + #endif //MPK_ON + } + else + { + free(psdata); + psdata = NULL; + return; + } + } + else + return; + + return; } @@ -1315,7 +1315,7 @@ void fnInternalPerlLaunchHandler(char* cmdLine) Function : fnGetPerlScreenName Description : This function creates the Perl screen name. - Gets called from main only once when the Perl NLM loads. + Gets called from main only once when the Perl NLM loads. Parameters : sPerlScreenName (OUT) - Resultant Perl screen name. @@ -1325,30 +1325,30 @@ void fnInternalPerlLaunchHandler(char* cmdLine) void fnGetPerlScreenName(char *sPerlScreenName) { - // HYAK: - // The logic for using 32 in the below array sizes is like this: - // The NetWare CLIB SDK documentation says that for base 2 conversion, - // this number must be minimum 8. Also, in the example of the documentation, - // 20 is used as the size and testing is done for bases from 2 upto 16. - // So, to simply chose a number above 20 and also keeping in mind not to reserve - // unnecessary big array sizes, I have chosen 32 ! - // Less than that may also suffice. - char sPerlRevision[32 * sizeof(char)] = {'\0'}; - char sPerlVersion[32 * sizeof(char)] = {'\0'}; - char sPerlSubVersion[32 * sizeof(char)] = {'\0'}; - - // The defines for PERL_REVISION, PERL_VERSION, PERL_SUBVERSION are available in - // patchlevel.h under root and gets included when perl.h is included. - // The number 10 below indicates base 10. - itoa(PERL_REVISION, sPerlRevision, 10); - itoa(PERL_VERSION, sPerlVersion, 10); - itoa(PERL_SUBVERSION, sPerlSubVersion, 10); - - // Concatenate substrings to get a string like Perl5.6.1 which is used as the screen name. - sprintf(sPerlScreenName, "%s%s.%s.%s", PERL_COMMAND_NAME, - sPerlRevision, sPerlVersion, sPerlSubVersion); - - return; + // HYAK: + // The logic for using 32 in the below array sizes is like this: + // The NetWare CLIB SDK documentation says that for base 2 conversion, + // this number must be minimum 8. Also, in the example of the documentation, + // 20 is used as the size and testing is done for bases from 2 upto 16. + // So, to simply chose a number above 20 and also keeping in mind not to reserve + // unnecessary big array sizes, I have chosen 32 ! + // Less than that may also suffice. + char sPerlRevision[32 * sizeof(char)] = {'\0'}; + char sPerlVersion[32 * sizeof(char)] = {'\0'}; + char sPerlSubVersion[32 * sizeof(char)] = {'\0'}; + + // The defines for PERL_REVISION, PERL_VERSION, PERL_SUBVERSION are available in + // patchlevel.h under root and gets included when perl.h is included. + // The number 10 below indicates base 10. + itoa(PERL_REVISION, sPerlRevision, 10); + itoa(PERL_VERSION, sPerlVersion, 10); + itoa(PERL_SUBVERSION, sPerlSubVersion, 10); + + // Concatenate substrings to get a string like Perl5.6.1 which is used as the screen name. + sprintf(sPerlScreenName, "%s%s.%s.%s", PERL_COMMAND_NAME, + sPerlRevision, sPerlVersion, sPerlSubVersion); + + return; } @@ -1376,13 +1376,13 @@ char** genviron = NULL; char *** nw_getenviron() { - if (genviron) - return (&genviron); // This might leak memory upto 11736 bytes on some versions of NetWare. + if (genviron) + return (&genviron); // This might leak memory upto 11736 bytes on some versions of NetWare. // return genviron; // Abending on some versions of NetWare. - else - fnSetUpEnvBlock(&genviron); + else + fnSetUpEnvBlock(&genviron); - return (&genviron); + return (&genviron); } @@ -1402,10 +1402,10 @@ nw_getenviron() void nw_freeenviron() { - if (genviron) - { - fnDestroyEnvBlock(genviron); - genviron=NULL; - } + if (genviron) + { + fnDestroyEnvBlock(genviron); + genviron=NULL; + } } diff --git a/NetWare/Nwpipe.c b/NetWare/Nwpipe.c index ce9c19800d..154ee09696 100644 --- a/NetWare/Nwpipe.c +++ b/NetWare/Nwpipe.c @@ -52,111 +52,111 @@ BOOL fnPipeFileMakeArgv(PTEMPPIPEFILE ptpf) { - int i=0, j=0; - int dindex = 0; - int sindex = 0; - - ptpf->m_argv_len = 0; - - - // Below 2 is added for the following reason: - // - The first one is for an additional value that will be added through ptpf->m_redirect. - // - The second one is for a NULL termination of the array. - // This is required for spawnvp API that takes a NULL-terminated array as its 3rd parameter. - // If the array is NOT NULL-terminated, then the server abends at the spawnvp call !! - ptpf->m_argv = (char **) malloc((ptpf->m_pipeCommand->m_argc + 2) * sizeof(char*)); - if (ptpf->m_argv == NULL) - return FALSE; - - // For memory allocation it is just +1 since the last one is only for NULL-termination - // and no memory is required to be allocated. - for(i=0; i<(ptpf->m_pipeCommand->m_argc + 1); i++) - { - ptpf->m_argv[i] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if (ptpf->m_argv[i] == NULL) - { - for(j=0; j<i; j++) - { - if(ptpf->m_argv[j]) - { - free(ptpf->m_argv[j]); - ptpf->m_argv[j] = NULL; - } - } - free(ptpf->m_argv); - ptpf->m_argv = NULL; - - return FALSE; - } - } - - // Copy over parsed items, removing "load" keyword if necessary. - sindex = ((stricmp(ptpf->m_pipeCommand->m_argv[0], LOAD_COMMAND) == 0) ? 1 : 0); - while (sindex < ptpf->m_pipeCommand->m_argc) - { - strcpy(ptpf->m_argv[dindex], ptpf->m_pipeCommand->m_argv[sindex]); - dindex++; - sindex++; - } - - if (stricmp(ptpf->m_argv[0], PERL_COMMAND_NAME) == 0) // If Perl is the first command. - { - ptpf->m_launchPerl = TRUE; - - #ifdef MPK_ON - ptpf->m_perlSynchSemaphore = kSemaphoreAlloc((BYTE *)"pipeSemaphore", 0); - #else - ptpf->m_perlSynchSemaphore = OpenLocalSemaphore(0); - #endif //MPK_ON - } - else if (stricmp(ptpf->m_argv[0], (char *)"perlglob") == 0) - ptpf->m_doPerlGlob = TRUE; - - - // Create last argument, which will redirect to or from the temp file - if (!ptpf->m_doPerlGlob || ptpf->m_mode) - { - if (!ptpf->m_mode) // If read mode? - { - if (ptpf->m_launchPerl) - strcpy(ptpf->m_redirect, (char *)">"); - else - strcpy(ptpf->m_redirect, (char *)"(CLIB_OPT)/>"); - } - else - { - if (ptpf->m_launchPerl) - strcpy(ptpf->m_redirect, (char *)"<"); - else - strcpy(ptpf->m_redirect, (char *)"(CLIB_OPT)/<"); - } - strcat(ptpf->m_redirect, ptpf->m_fileName); - - if (ptpf->m_launchPerl) - { - char tbuf[15] = {'\0'}; - sprintf(tbuf, (char *)" -{%x", ptpf->m_perlSynchSemaphore); - strcat(ptpf->m_redirect, tbuf); - } - - strcpy(ptpf->m_argv[dindex], (char*) ptpf->m_redirect); - dindex++; - } - - if (dindex < (ptpf->m_pipeCommand->m_argc + 1)) - { - if(ptpf->m_argv[dindex]) - { - free(ptpf->m_argv[dindex]); - ptpf->m_argv[dindex] = NULL; // NULL termination - required for spawnvp call. - } - } - - ptpf->m_argv_len = dindex; // Length of the argv array OR number of argv string values. - ptpf->m_argv[ptpf->m_argv_len] = NULL; // NULL termination - required for spawnvp call. - - - return TRUE; + int i=0, j=0; + int dindex = 0; + int sindex = 0; + + ptpf->m_argv_len = 0; + + + // Below 2 is added for the following reason: + // - The first one is for an additional value that will be added through ptpf->m_redirect. + // - The second one is for a NULL termination of the array. + // This is required for spawnvp API that takes a NULL-terminated array as its 3rd parameter. + // If the array is NOT NULL-terminated, then the server abends at the spawnvp call !! + ptpf->m_argv = (char **) malloc((ptpf->m_pipeCommand->m_argc + 2) * sizeof(char*)); + if (ptpf->m_argv == NULL) + return FALSE; + + // For memory allocation it is just +1 since the last one is only for NULL-termination + // and no memory is required to be allocated. + for(i=0; i<(ptpf->m_pipeCommand->m_argc + 1); i++) + { + ptpf->m_argv[i] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if (ptpf->m_argv[i] == NULL) + { + for(j=0; j<i; j++) + { + if(ptpf->m_argv[j]) + { + free(ptpf->m_argv[j]); + ptpf->m_argv[j] = NULL; + } + } + free(ptpf->m_argv); + ptpf->m_argv = NULL; + + return FALSE; + } + } + + // Copy over parsed items, removing "load" keyword if necessary. + sindex = ((stricmp(ptpf->m_pipeCommand->m_argv[0], LOAD_COMMAND) == 0) ? 1 : 0); + while (sindex < ptpf->m_pipeCommand->m_argc) + { + strcpy(ptpf->m_argv[dindex], ptpf->m_pipeCommand->m_argv[sindex]); + dindex++; + sindex++; + } + + if (stricmp(ptpf->m_argv[0], PERL_COMMAND_NAME) == 0) // If Perl is the first command. + { + ptpf->m_launchPerl = TRUE; + + #ifdef MPK_ON + ptpf->m_perlSynchSemaphore = kSemaphoreAlloc((BYTE *)"pipeSemaphore", 0); + #else + ptpf->m_perlSynchSemaphore = OpenLocalSemaphore(0); + #endif //MPK_ON + } + else if (stricmp(ptpf->m_argv[0], (char *)"perlglob") == 0) + ptpf->m_doPerlGlob = TRUE; + + + // Create last argument, which will redirect to or from the temp file + if (!ptpf->m_doPerlGlob || ptpf->m_mode) + { + if (!ptpf->m_mode) // If read mode? + { + if (ptpf->m_launchPerl) + strcpy(ptpf->m_redirect, (char *)">"); + else + strcpy(ptpf->m_redirect, (char *)"(CLIB_OPT)/>"); + } + else + { + if (ptpf->m_launchPerl) + strcpy(ptpf->m_redirect, (char *)"<"); + else + strcpy(ptpf->m_redirect, (char *)"(CLIB_OPT)/<"); + } + strcat(ptpf->m_redirect, ptpf->m_fileName); + + if (ptpf->m_launchPerl) + { + char tbuf[15] = {'\0'}; + sprintf(tbuf, (char *)" -{%x", ptpf->m_perlSynchSemaphore); + strcat(ptpf->m_redirect, tbuf); + } + + strcpy(ptpf->m_argv[dindex], (char*) ptpf->m_redirect); + dindex++; + } + + if (dindex < (ptpf->m_pipeCommand->m_argc + 1)) + { + if(ptpf->m_argv[dindex]) + { + free(ptpf->m_argv[dindex]); + ptpf->m_argv[dindex] = NULL; // NULL termination - required for spawnvp call. + } + } + + ptpf->m_argv_len = dindex; // Length of the argv array OR number of argv string values. + ptpf->m_argv[ptpf->m_argv_len] = NULL; // NULL termination - required for spawnvp call. + + + return TRUE; } @@ -167,8 +167,8 @@ BOOL fnPipeFileMakeArgv(PTEMPPIPEFILE ptpf) Description : This function opens the pipe file. Parameters : ptpf (IN) - Input structure. - command (IN) - Input command string. - mode (IN) - Mode of opening. + command (IN) - Input command string. + mode (IN) - Mode of opening. Returns : File pointer. @@ -176,281 +176,281 @@ BOOL fnPipeFileMakeArgv(PTEMPPIPEFILE ptpf) FILE* fnPipeFileOpen(PTEMPPIPEFILE ptpf, char* command, char* mode) { - int i=0, j=0; + int i=0, j=0; - char tempName[_MAX_PATH] = {'\0'}; + char tempName[_MAX_PATH] = {'\0'}; - ptpf->m_fileName = (char *) malloc(_MAX_PATH * sizeof(char)); - if(ptpf->m_fileName == NULL) - return NULL; + ptpf->m_fileName = (char *) malloc(_MAX_PATH * sizeof(char)); + if(ptpf->m_fileName == NULL) + return NULL; - // The char array is emptied so that there is no junk characters. - strncpy(ptpf->m_fileName, "", (_MAX_PATH * sizeof(char))); - + // The char array is emptied so that there is no junk characters. + strncpy(ptpf->m_fileName, "", (_MAX_PATH * sizeof(char))); + - // Save off stuff - // - if(strchr(mode,'r') != 0) - ptpf->m_mode = FALSE; // Read mode - else if(strchr(mode,'w') != 0) - ptpf->m_mode = TRUE; // Write mode - else - { - if(ptpf->m_fileName != NULL) - { + // Save off stuff + // + if(strchr(mode,'r') != 0) + ptpf->m_mode = FALSE; // Read mode + else if(strchr(mode,'w') != 0) + ptpf->m_mode = TRUE; // Write mode + else + { + if(ptpf->m_fileName != NULL) + { // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; - } + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; + } - return NULL; - } + return NULL; + } - ptpf->m_pipeCommand = (PCOMMANDLINEPARSER) malloc(sizeof(COMMANDLINEPARSER)); - if (!ptpf->m_pipeCommand) - { + ptpf->m_pipeCommand = (PCOMMANDLINEPARSER) malloc(sizeof(COMMANDLINEPARSER)); + if (!ptpf->m_pipeCommand) + { // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; - return NULL; - } + return NULL; + } - // Initialise the variables - ptpf->m_pipeCommand->m_isValid = TRUE; + // Initialise the variables + ptpf->m_pipeCommand->m_isValid = TRUE; /**** // Commented since these are not being used. Still retained here. // To be removed once things are proved to be working fine to a good confident level, - ptpf->m_pipeCommand->m_redirInName = NULL; - ptpf->m_pipeCommand->m_redirOutName = NULL; - ptpf->m_pipeCommand->m_redirErrName = NULL; - ptpf->m_pipeCommand->m_redirBothName = NULL; - ptpf->m_pipeCommand->nextarg = NULL; + ptpf->m_pipeCommand->m_redirInName = NULL; + ptpf->m_pipeCommand->m_redirOutName = NULL; + ptpf->m_pipeCommand->m_redirErrName = NULL; + ptpf->m_pipeCommand->m_redirBothName = NULL; + ptpf->m_pipeCommand->nextarg = NULL; ****/ - ptpf->m_pipeCommand->sSkippedToken = NULL; - ptpf->m_pipeCommand->m_argv = NULL; - ptpf->m_pipeCommand->new_argv = NULL; + ptpf->m_pipeCommand->sSkippedToken = NULL; + ptpf->m_pipeCommand->m_argv = NULL; + ptpf->m_pipeCommand->new_argv = NULL; - #ifdef MPK_ON - ptpf->m_pipeCommand->m_qSemaphore = NULL; - #else - ptpf->m_pipeCommand->m_qSemaphore = 0L; - #endif //MPK_ON + #ifdef MPK_ON + ptpf->m_pipeCommand->m_qSemaphore = NULL; + #else + ptpf->m_pipeCommand->m_qSemaphore = 0L; + #endif //MPK_ON - ptpf->m_pipeCommand->m_noScreen = 0; - ptpf->m_pipeCommand->m_AutoDestroy = 0; - ptpf->m_pipeCommand->m_argc = 0; - ptpf->m_pipeCommand->m_argv_len = 1; + ptpf->m_pipeCommand->m_noScreen = 0; + ptpf->m_pipeCommand->m_AutoDestroy = 0; + ptpf->m_pipeCommand->m_argc = 0; + ptpf->m_pipeCommand->m_argv_len = 1; - ptpf->m_pipeCommand->m_argv = (char **) malloc(ptpf->m_pipeCommand->m_argv_len * sizeof(char *)); - if (ptpf->m_pipeCommand->m_argv == NULL) - { - free(ptpf->m_pipeCommand); - ptpf->m_pipeCommand = NULL; + ptpf->m_pipeCommand->m_argv = (char **) malloc(ptpf->m_pipeCommand->m_argv_len * sizeof(char *)); + if (ptpf->m_pipeCommand->m_argv == NULL) + { + free(ptpf->m_pipeCommand); + ptpf->m_pipeCommand = NULL; // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); - - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; - - return NULL; - } - ptpf->m_pipeCommand->m_argv[0] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if (ptpf->m_pipeCommand->m_argv[0] == NULL) - { - for(j=0; j<i; j++) - { - if(ptpf->m_pipeCommand->m_argv[j]) - { - free(ptpf->m_pipeCommand->m_argv[j]); - ptpf->m_pipeCommand->m_argv[j]=NULL; - } - } - free(ptpf->m_pipeCommand->m_argv); - ptpf->m_pipeCommand->m_argv=NULL; - - free(ptpf->m_pipeCommand); - ptpf->m_pipeCommand = NULL; + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); + + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; + + return NULL; + } + ptpf->m_pipeCommand->m_argv[0] = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if (ptpf->m_pipeCommand->m_argv[0] == NULL) + { + for(j=0; j<i; j++) + { + if(ptpf->m_pipeCommand->m_argv[j]) + { + free(ptpf->m_pipeCommand->m_argv[j]); + ptpf->m_pipeCommand->m_argv[j]=NULL; + } + } + free(ptpf->m_pipeCommand->m_argv); + ptpf->m_pipeCommand->m_argv=NULL; + + free(ptpf->m_pipeCommand); + ptpf->m_pipeCommand = NULL; // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; - return NULL; - } + return NULL; + } - ptpf->m_redirect = (char *) malloc(MAX_DN_BYTES * sizeof(char)); - if (ptpf->m_redirect == NULL) - { - for(i=0; i<ptpf->m_pipeCommand->m_argv_len; i++) - { - if(ptpf->m_pipeCommand->m_argv[i] != NULL) - { - free(ptpf->m_pipeCommand->m_argv[i]); - ptpf->m_pipeCommand->m_argv[i] = NULL; - } - } + ptpf->m_redirect = (char *) malloc(MAX_DN_BYTES * sizeof(char)); + if (ptpf->m_redirect == NULL) + { + for(i=0; i<ptpf->m_pipeCommand->m_argv_len; i++) + { + if(ptpf->m_pipeCommand->m_argv[i] != NULL) + { + free(ptpf->m_pipeCommand->m_argv[i]); + ptpf->m_pipeCommand->m_argv[i] = NULL; + } + } - free(ptpf->m_pipeCommand->m_argv); - ptpf->m_pipeCommand->m_argv = NULL; + free(ptpf->m_pipeCommand->m_argv); + ptpf->m_pipeCommand->m_argv = NULL; - free(ptpf->m_pipeCommand); - ptpf->m_pipeCommand = NULL; + free(ptpf->m_pipeCommand); + ptpf->m_pipeCommand = NULL; // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); - - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; - - return NULL; - } - - // The char array is emptied. - // If it is not done so, then it could contain some junk values and the string length in that case - // will not be zero. This causes erroneous results in fnPipeFileMakeArgv() function - // where strlen(ptpf->m_redirect) is used as a check for incrementing the parameter count and - // it will wrongly get incremented in such cases. - strncpy(ptpf->m_redirect, "", (MAX_DN_BYTES * sizeof(char))); - - // Parse the parameters. - fnCommandLineParser(ptpf->m_pipeCommand, (char *)command, TRUE); - if (!ptpf->m_pipeCommand->m_isValid) - { - fnTempPipeFileReleaseMemory(ptpf); - return NULL; - } - - - // Create a temporary file name - // - strncpy ( tempName, fnNwGetEnvironmentStr((char *)"TEMP", NWDEFPERLTEMP), (_MAX_PATH - 20) ); - tempName[_MAX_PATH-20] = '\0'; - strcat(tempName, (char *)"\\plXXXXXX.tmp"); - if (!fnMy_MkTemp(tempName)) - { - fnTempPipeFileReleaseMemory(ptpf); - return NULL; - } - - // create a temporary place-holder file - fclose(fopen(tempName, (char *)"w")); - strcpy(ptpf->m_fileName, tempName); - - - // Make the argument array - if(!fnPipeFileMakeArgv(ptpf)) - { - fnTempPipeFileReleaseMemory(ptpf); - - // Release additional memory - if(ptpf->m_argv != NULL) - { - for(i=0; i<ptpf->m_argv_len; i++) - { - if(ptpf->m_argv[i] != NULL) - { - free(ptpf->m_argv[i]); - ptpf->m_argv[i] = NULL; - } - } - - free(ptpf->m_argv); - ptpf->m_argv = NULL; - } - - return NULL; - } - - - // Open the temp file in the appropriate way... - // - if (!ptpf->m_mode) // If Read mode? - { - // we wish to spawn a command, intercept its output, - // and then get that output - // - if (!ptpf->m_argv[0]) - { - fnTempPipeFileReleaseMemory(ptpf); - - // Release additional memory - if(ptpf->m_argv != NULL) - { - for(i=0; i<ptpf->m_argv_len; i++) - { - if(ptpf->m_argv[i] != NULL) - { - free(ptpf->m_argv[i]); - ptpf->m_argv[i] = NULL; - } - } - - free(ptpf->m_argv); - ptpf->m_argv = NULL; - } - - return NULL; - } - - if (ptpf->m_launchPerl) - fnPipeFileDoPerlLaunch(ptpf); - else - if (ptpf->m_doPerlGlob) - fnDoPerlGlob(ptpf->m_argv, ptpf->m_fileName); // hack to do perl globbing - else - spawnvp(P_WAIT, ptpf->m_argv[0], ptpf->m_argv); - - ptpf->m_file = fopen (ptpf->m_fileName, (char *)"r"); // Get the Pipe file handle - } - else if (ptpf->m_mode) // If Write mode? - { - // we wish to open the file for writing now and - // do the command later - // - ptpf->m_file = fopen(ptpf->m_fileName, (char *)"w"); - } - - fnTempPipeFileReleaseMemory(ptpf); - - // Release additional memory - if(ptpf->m_argv != NULL) - { - for(i=0; i<(ptpf->m_argv_len); i++) - { - if(ptpf->m_argv[i] != NULL) - { - free(ptpf->m_argv[i]); - ptpf->m_argv[i] = NULL; - } - } - - free(ptpf->m_argv); - ptpf->m_argv = NULL; - } - - - return ptpf->m_file; // Return the Pipe file handle. + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); + + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; + + return NULL; + } + + // The char array is emptied. + // If it is not done so, then it could contain some junk values and the string length in that case + // will not be zero. This causes erroneous results in fnPipeFileMakeArgv() function + // where strlen(ptpf->m_redirect) is used as a check for incrementing the parameter count and + // it will wrongly get incremented in such cases. + strncpy(ptpf->m_redirect, "", (MAX_DN_BYTES * sizeof(char))); + + // Parse the parameters. + fnCommandLineParser(ptpf->m_pipeCommand, (char *)command, TRUE); + if (!ptpf->m_pipeCommand->m_isValid) + { + fnTempPipeFileReleaseMemory(ptpf); + return NULL; + } + + + // Create a temporary file name + // + strncpy ( tempName, fnNwGetEnvironmentStr((char *)"TEMP", NWDEFPERLTEMP), (_MAX_PATH - 20) ); + tempName[_MAX_PATH-20] = '\0'; + strcat(tempName, (char *)"\\plXXXXXX.tmp"); + if (!fnMy_MkTemp(tempName)) + { + fnTempPipeFileReleaseMemory(ptpf); + return NULL; + } + + // create a temporary place-holder file + fclose(fopen(tempName, (char *)"w")); + strcpy(ptpf->m_fileName, tempName); + + + // Make the argument array + if(!fnPipeFileMakeArgv(ptpf)) + { + fnTempPipeFileReleaseMemory(ptpf); + + // Release additional memory + if(ptpf->m_argv != NULL) + { + for(i=0; i<ptpf->m_argv_len; i++) + { + if(ptpf->m_argv[i] != NULL) + { + free(ptpf->m_argv[i]); + ptpf->m_argv[i] = NULL; + } + } + + free(ptpf->m_argv); + ptpf->m_argv = NULL; + } + + return NULL; + } + + + // Open the temp file in the appropriate way... + // + if (!ptpf->m_mode) // If Read mode? + { + // we wish to spawn a command, intercept its output, + // and then get that output + // + if (!ptpf->m_argv[0]) + { + fnTempPipeFileReleaseMemory(ptpf); + + // Release additional memory + if(ptpf->m_argv != NULL) + { + for(i=0; i<ptpf->m_argv_len; i++) + { + if(ptpf->m_argv[i] != NULL) + { + free(ptpf->m_argv[i]); + ptpf->m_argv[i] = NULL; + } + } + + free(ptpf->m_argv); + ptpf->m_argv = NULL; + } + + return NULL; + } + + if (ptpf->m_launchPerl) + fnPipeFileDoPerlLaunch(ptpf); + else + if (ptpf->m_doPerlGlob) + fnDoPerlGlob(ptpf->m_argv, ptpf->m_fileName); // hack to do perl globbing + else + spawnvp(P_WAIT, ptpf->m_argv[0], ptpf->m_argv); + + ptpf->m_file = fopen (ptpf->m_fileName, (char *)"r"); // Get the Pipe file handle + } + else if (ptpf->m_mode) // If Write mode? + { + // we wish to open the file for writing now and + // do the command later + // + ptpf->m_file = fopen(ptpf->m_fileName, (char *)"w"); + } + + fnTempPipeFileReleaseMemory(ptpf); + + // Release additional memory + if(ptpf->m_argv != NULL) + { + for(i=0; i<(ptpf->m_argv_len); i++) + { + if(ptpf->m_argv[i] != NULL) + { + free(ptpf->m_argv[i]); + ptpf->m_argv[i] = NULL; + } + } + + free(ptpf->m_argv); + ptpf->m_argv = NULL; + } + + + return ptpf->m_file; // Return the Pipe file handle. } @@ -468,71 +468,71 @@ FILE* fnPipeFileOpen(PTEMPPIPEFILE ptpf, char* command, char* mode) void fnPipeFileClose(PTEMPPIPEFILE ptpf) { - int i = 0; - - if (ptpf->m_mode) // If Write mode? - { - // we wish to spawn a command using our temp file for - // its input - // - if(ptpf->m_file != NULL) - { - fclose (ptpf->m_file); - ptpf->m_file = NULL; - } - - if (ptpf->m_launchPerl) - fnPipeFileDoPerlLaunch(ptpf); - else if (ptpf->m_argv) - spawnvp(P_WAIT, ptpf->m_argv[0], ptpf->m_argv); - } - - - // Close the temporary Pipe File, if opened - if (ptpf->m_file) - { - fclose(ptpf->m_file); - ptpf->m_file = NULL; - } - // Delete the temporary Pipe Filename if still valid and free the memory associated with the file name. - if(ptpf->m_fileName != NULL) - { + int i = 0; + + if (ptpf->m_mode) // If Write mode? + { + // we wish to spawn a command using our temp file for + // its input + // + if(ptpf->m_file != NULL) + { + fclose (ptpf->m_file); + ptpf->m_file = NULL; + } + + if (ptpf->m_launchPerl) + fnPipeFileDoPerlLaunch(ptpf); + else if (ptpf->m_argv) + spawnvp(P_WAIT, ptpf->m_argv[0], ptpf->m_argv); + } + + + // Close the temporary Pipe File, if opened + if (ptpf->m_file) + { + fclose(ptpf->m_file); + ptpf->m_file = NULL; + } + // Delete the temporary Pipe Filename if still valid and free the memory associated with the file name. + if(ptpf->m_fileName != NULL) + { // if (strlen(ptpf->m_fileName)) - if (ptpf->m_fileName) - unlink(ptpf->m_fileName); + if (ptpf->m_fileName) + unlink(ptpf->m_fileName); - free(ptpf->m_fileName); - ptpf->m_fileName = NULL; - } + free(ptpf->m_fileName); + ptpf->m_fileName = NULL; + } /** - if(ptpf->m_argv != NULL) - { - for(i=0; i<(ptpf->m_argv_len); i++) - { - if(ptpf->m_argv[i] != NULL) - { - free(ptpf->m_argv[i]); - ptpf->m_argv[i] = NULL; - } - } - - free(ptpf->m_argv); - ptpf->m_argv = NULL; - } + if(ptpf->m_argv != NULL) + { + for(i=0; i<(ptpf->m_argv_len); i++) + { + if(ptpf->m_argv[i] != NULL) + { + free(ptpf->m_argv[i]); + ptpf->m_argv[i] = NULL; + } + } + + free(ptpf->m_argv); + ptpf->m_argv = NULL; + } **/ - if (ptpf->m_perlSynchSemaphore) - { - #ifdef MPK_ON - kSemaphoreFree(ptpf->m_perlSynchSemaphore); - #else - CloseLocalSemaphore(ptpf->m_perlSynchSemaphore); - #endif //MPK_ON - } + if (ptpf->m_perlSynchSemaphore) + { + #ifdef MPK_ON + kSemaphoreFree(ptpf->m_perlSynchSemaphore); + #else + CloseLocalSemaphore(ptpf->m_perlSynchSemaphore); + #endif //MPK_ON + } - return; + return; } @@ -550,30 +550,30 @@ void fnPipeFileClose(PTEMPPIPEFILE ptpf) void fnPipeFileDoPerlLaunch(PTEMPPIPEFILE ptpf) { - char curdir[_MAX_PATH] = {'\0'}; - char* pcwd = NULL; - - int i=0; - - - // save off the current working directory to restore later - // this is just a hack! these problems of synchronization and - // restoring calling context need a much better solution! - pcwd = (char *)getcwd(curdir, sizeof(curdir)-1); - fnSystemCommand(ptpf->m_argv, ptpf->m_argv_len); - if (ptpf->m_perlSynchSemaphore) - { - #ifdef MPK_ON - kSemaphoreWait(ptpf->m_perlSynchSemaphore); - #else - WaitOnLocalSemaphore(ptpf->m_perlSynchSemaphore); - #endif //MPK_ON - } - - if (pcwd) - chdir(pcwd); - - return; + char curdir[_MAX_PATH] = {'\0'}; + char* pcwd = NULL; + + int i=0; + + + // save off the current working directory to restore later + // this is just a hack! these problems of synchronization and + // restoring calling context need a much better solution! + pcwd = (char *)getcwd(curdir, sizeof(curdir)-1); + fnSystemCommand(ptpf->m_argv, ptpf->m_argv_len); + if (ptpf->m_perlSynchSemaphore) + { + #ifdef MPK_ON + kSemaphoreWait(ptpf->m_perlSynchSemaphore); + #else + WaitOnLocalSemaphore(ptpf->m_perlSynchSemaphore); + #endif //MPK_ON + } + + if (pcwd) + chdir(pcwd); + + return; } @@ -591,27 +591,27 @@ void fnPipeFileDoPerlLaunch(PTEMPPIPEFILE ptpf) void fnTempPipeFile(PTEMPPIPEFILE ptpf) { - ptpf->m_fileName = NULL; + ptpf->m_fileName = NULL; - ptpf->m_mode = FALSE; // Default mode = Read mode. - ptpf->m_file = NULL; - ptpf->m_pipeCommand = NULL; - ptpf->m_argv = NULL; + ptpf->m_mode = FALSE; // Default mode = Read mode. + ptpf->m_file = NULL; + ptpf->m_pipeCommand = NULL; + ptpf->m_argv = NULL; - ptpf->m_redirect = NULL; + ptpf->m_redirect = NULL; - ptpf->m_launchPerl = FALSE; - ptpf->m_doPerlGlob = FALSE; + ptpf->m_launchPerl = FALSE; + ptpf->m_doPerlGlob = FALSE; - #ifdef MPK_ON - ptpf->m_perlSynchSemaphore = NULL; - #else - ptpf->m_perlSynchSemaphore = 0L; - #endif + #ifdef MPK_ON + ptpf->m_perlSynchSemaphore = NULL; + #else + ptpf->m_perlSynchSemaphore = 0L; + #endif - ptpf->m_argv_len = 0; + ptpf->m_argv_len = 0; - return; + return; } @@ -629,76 +629,76 @@ void fnTempPipeFile(PTEMPPIPEFILE ptpf) void fnTempPipeFileReleaseMemory(PTEMPPIPEFILE ptpf) { - int i=0; - - - if (ptpf->m_pipeCommand) - { - if(ptpf->m_pipeCommand->m_argv != NULL) - { - for(i=0; i<ptpf->m_pipeCommand->m_argv_len; i++) - { - if(ptpf->m_pipeCommand->m_argv[i] != NULL) - { - free(ptpf->m_pipeCommand->m_argv[i]); - ptpf->m_pipeCommand->m_argv[i] = NULL; - } - } - - free(ptpf->m_pipeCommand->m_argv); - ptpf->m_pipeCommand->m_argv = NULL; - } - - if(ptpf->m_pipeCommand->sSkippedToken != NULL) - { - free(ptpf->m_pipeCommand->sSkippedToken); - ptpf->m_pipeCommand->sSkippedToken = NULL; - } + int i=0; + + + if (ptpf->m_pipeCommand) + { + if(ptpf->m_pipeCommand->m_argv != NULL) + { + for(i=0; i<ptpf->m_pipeCommand->m_argv_len; i++) + { + if(ptpf->m_pipeCommand->m_argv[i] != NULL) + { + free(ptpf->m_pipeCommand->m_argv[i]); + ptpf->m_pipeCommand->m_argv[i] = NULL; + } + } + + free(ptpf->m_pipeCommand->m_argv); + ptpf->m_pipeCommand->m_argv = NULL; + } + + if(ptpf->m_pipeCommand->sSkippedToken != NULL) + { + free(ptpf->m_pipeCommand->sSkippedToken); + ptpf->m_pipeCommand->sSkippedToken = NULL; + } /**** // Commented since these are not being used. Still retained here. // To be removed once things are proved to be working fine to a good confident level, - if(ptpf->m_pipeCommand->nextarg) - { - free(ptpf->m_pipeCommand->nextarg); - ptpf->m_pipeCommand->nextarg = NULL; - } - - if(ptpf->m_pipeCommand->m_redirInName) - { - free(ptpf->m_pipeCommand->m_redirInName); - ptpf->m_pipeCommand->m_redirInName = NULL; - } - if(ptpf->m_pipeCommand->m_redirOutName) - { - free(ptpf->m_pipeCommand->m_redirOutName); - ptpf->m_pipeCommand->m_redirOutName = NULL; - } - if(ptpf->m_pipeCommand->m_redirErrName) - { - free(ptpf->m_pipeCommand->m_redirErrName); - ptpf->m_pipeCommand->m_redirErrName = NULL; - } - if(ptpf->m_pipeCommand->m_redirBothName) - { - free(ptpf->m_pipeCommand->m_redirBothName); - ptpf->m_pipeCommand->m_redirBothName = NULL; - } + if(ptpf->m_pipeCommand->nextarg) + { + free(ptpf->m_pipeCommand->nextarg); + ptpf->m_pipeCommand->nextarg = NULL; + } + + if(ptpf->m_pipeCommand->m_redirInName) + { + free(ptpf->m_pipeCommand->m_redirInName); + ptpf->m_pipeCommand->m_redirInName = NULL; + } + if(ptpf->m_pipeCommand->m_redirOutName) + { + free(ptpf->m_pipeCommand->m_redirOutName); + ptpf->m_pipeCommand->m_redirOutName = NULL; + } + if(ptpf->m_pipeCommand->m_redirErrName) + { + free(ptpf->m_pipeCommand->m_redirErrName); + ptpf->m_pipeCommand->m_redirErrName = NULL; + } + if(ptpf->m_pipeCommand->m_redirBothName) + { + free(ptpf->m_pipeCommand->m_redirBothName); + ptpf->m_pipeCommand->m_redirBothName = NULL; + } ****/ - if(ptpf->m_pipeCommand != NULL) - { - free(ptpf->m_pipeCommand); - ptpf->m_pipeCommand = NULL; - } - } + if(ptpf->m_pipeCommand != NULL) + { + free(ptpf->m_pipeCommand); + ptpf->m_pipeCommand = NULL; + } + } - if(ptpf->m_redirect != NULL) - { - free(ptpf->m_redirect); - ptpf->m_redirect = NULL; - } + if(ptpf->m_redirect != NULL) + { + free(ptpf->m_redirect); + ptpf->m_redirect = NULL; + } - return; + return; } diff --git a/NetWare/deb.h b/NetWare/deb.h index e79a8f41a7..a0000bc041 100644 --- a/NetWare/deb.h +++ b/NetWare/deb.h @@ -25,21 +25,21 @@ #if defined(DEBUGON) && !defined(USE_D2) - //debug build and d1 flag is used, so enable IDB - #define DBGMESG ConsolePrintf - #define IDB(x) \ - ConsolePrintf(x); \ - _asm {int 3} + //debug build and d1 flag is used, so enable IDB + #define DBGMESG ConsolePrintf + #define IDB(x) \ + ConsolePrintf(x); \ + _asm {int 3} #else - #if defined(USE_D2) - //debug build and d2 flag is used, so disable IDB - #define DBGMESG ConsolePrintf - #define IDB ConsolePrintf - #else - //release build, so disable DBGMESG and IDB - #define DBGMESG - #define IDB - #endif //if defined(USE_D2) + #if defined(USE_D2) + //debug build and d2 flag is used, so disable IDB + #define DBGMESG ConsolePrintf + #define IDB ConsolePrintf + #else + //release build, so disable DBGMESG and IDB + #define DBGMESG + #define IDB + #endif //if defined(USE_D2) #endif //if defined(DEBUGON) && !defined(USE_D2) diff --git a/NetWare/intdef.h b/NetWare/intdef.h index 4c566c4e45..b0bcf010b5 100644 --- a/NetWare/intdef.h +++ b/NetWare/intdef.h @@ -47,8 +47,8 @@ //#define strcpy(x,y) NWLstrbcpy(x,y,NWstrlen(y)+1) #define strcpy(x,y) \ - NWstrncpy(x,y,NWstrlen(y)); \ - x[NWstrlen(y)] ='\0'; + NWstrncpy(x,y,NWstrlen(y)); \ + x[NWstrlen(y)] ='\0'; #define strncpy(x,y,z) NWLstrbcpy(x,y,(z + 1)) #define strcat(x,y) NWLstrbcpy((x + NWstrlen(x)), y, (NWstrlen(y) +1)) #define strncmp(s1,s2,l) NWgstrncmp(s1,s2,l) @@ -58,28 +58,28 @@ #define wsprintf NWsprintf #define strncat(x,y,l) \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strncat\n"); \ - strncat(x,y,l); + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strncat\n"); \ + strncat(x,y,l); #define strdup(s1) \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strdup\n"); \ - strdup(s1); + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strdup\n"); \ + strdup(s1); #define strlist \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strlist\n"); \ - strlist; + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strlist\n"); \ + strlist; #define strlwr(s1) \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strlwr\n"); \ - strlwr(s1); + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strlwr\n"); \ + strlwr(s1); #define strnset(s1,l1,l2) \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strnset\n"); \ - strnset(s1,l1,l2); + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strnset\n"); \ + strnset(s1,l1,l2); #define strset(s1,l1) \ - NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strset\n"); \ - strset(s1,l1); + NWsprintf("oops!!! Not yet defined for NWI18N, define in intdef.h, still using strset\n"); \ + strset(s1,l1); #endif // __INTDEF__ diff --git a/NetWare/interface.c b/NetWare/interface.c index be3eddf149..cd2c6deb08 100644 --- a/NetWare/interface.c +++ b/NetWare/interface.c @@ -41,58 +41,58 @@ ClsPerlHost::~ClsPerlHost() ClsPerlHost::VersionNumber() { - return 0; + return 0; } bool ClsPerlHost::RegisterWithThreadTable() { - return(fnRegisterWithThreadTable()); + return(fnRegisterWithThreadTable()); } bool ClsPerlHost::UnregisterWithThreadTable() { - return(fnUnregisterWithThreadTable()); + return(fnUnregisterWithThreadTable()); } int ClsPerlHost::PerlCreate(PerlInterpreter *my_perl) { /* if (!(my_perl = perl_alloc())) // Allocate memory for Perl. - return (1);*/ + return (1);*/ perl_construct(my_perl); - return 1; + return 1; } int ClsPerlHost::PerlParse(PerlInterpreter *my_perl, int argc, char** argv, char** env) { - return(perl_parse(my_perl, xs_init, argc, argv, env)); // Parse the command line. + return(perl_parse(my_perl, xs_init, argc, argv, env)); // Parse the command line. } int ClsPerlHost::PerlRun(PerlInterpreter *my_perl) { - return(perl_run(my_perl)); // Run Perl. + return(perl_run(my_perl)); // Run Perl. } int ClsPerlHost::PerlDestroy(PerlInterpreter *my_perl) { - return(perl_destruct(my_perl)); // Destructor for Perl. + return(perl_destruct(my_perl)); // Destructor for Perl. } void ClsPerlHost::PerlFree(PerlInterpreter *my_perl) { - perl_free(my_perl); // Free the memory allocated for Perl. + perl_free(my_perl); // Free the memory allocated for Perl. - // Remove the thread context set during Perl_set_context - // This is added here since for web script there is no other place this gets executed - // and it cannot be included into cgi2perl.xs unless this symbol is exported. - Remove_Thread_Ctx(); + // Remove the thread context set during Perl_set_context + // This is added here since for web script there is no other place this gets executed + // and it cannot be included into cgi2perl.xs unless this symbol is exported. + Remove_Thread_Ctx(); } /*============================================================================================ @@ -109,58 +109,58 @@ ClsPerlHost::PerlFree(PerlInterpreter *my_perl) static void xs_init(pTHX) { - char *file = __FILE__; + char *file = __FILE__; - dXSUB_SYS; - newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); + dXSUB_SYS; + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); } EXTERN_C int RunPerl(int argc, char **argv, char **env) { - int exitstatus = 0; - ClsPerlHost nlm; - - PerlInterpreter *my_perl = NULL; // defined in Perl.h - PerlInterpreter *new_perl = NULL; // defined in Perl.h - - PERL_SYS_INIT(&argc, &argv); - - if (!(my_perl = perl_alloc())) // Allocate memory for Perl. - return (1); - - if(nlm.PerlCreate(my_perl)) - { - PL_perl_destruct_level = 0; - - if(!nlm.PerlParse(my_perl, argc, argv, env)) - { - #if defined(TOP_CLONE) && defined(USE_ITHREADS) // XXXXXX testing - new_perl = perl_clone(my_perl, 1); - - (void) perl_run(new_perl); // Run Perl. - PERL_SET_THX(my_perl); - #else - (void) nlm.PerlRun(my_perl); - #endif - } - exitstatus = nlm.PerlDestroy(my_perl); - } - if(my_perl) - nlm.PerlFree(my_perl); - - #ifdef USE_ITHREADS - if (new_perl) - { - PERL_SET_THX(new_perl); - exitstatus = nlm.PerlDestroy(new_perl); - nlm.PerlFree(my_perl); - } - #endif - - PERL_SYS_TERM(); - return exitstatus; + int exitstatus = 0; + ClsPerlHost nlm; + + PerlInterpreter *my_perl = NULL; // defined in Perl.h + PerlInterpreter *new_perl = NULL; // defined in Perl.h + + PERL_SYS_INIT(&argc, &argv); + + if (!(my_perl = perl_alloc())) // Allocate memory for Perl. + return (1); + + if(nlm.PerlCreate(my_perl)) + { + PL_perl_destruct_level = 0; + + if(!nlm.PerlParse(my_perl, argc, argv, env)) + { + #if defined(TOP_CLONE) && defined(USE_ITHREADS) // XXXXXX testing + new_perl = perl_clone(my_perl, 1); + + (void) perl_run(new_perl); // Run Perl. + PERL_SET_THX(my_perl); + #else + (void) nlm.PerlRun(my_perl); + #endif + } + exitstatus = nlm.PerlDestroy(my_perl); + } + if(my_perl) + nlm.PerlFree(my_perl); + + #ifdef USE_ITHREADS + if (new_perl) + { + PERL_SET_THX(new_perl); + exitstatus = nlm.PerlDestroy(new_perl); + nlm.PerlFree(my_perl); + } + #endif + + PERL_SYS_TERM(); + return exitstatus; } @@ -173,7 +173,7 @@ int RunPerl(int argc, char **argv, char **env) // IPerlHost* AllocStdPerl() { - return (IPerlHost*) new ClsPerlHost(); + return (IPerlHost*) new ClsPerlHost(); } @@ -185,7 +185,7 @@ IPerlHost* AllocStdPerl() // void FreeStdPerl(IPerlHost* pPerlHost) { - if (pPerlHost) - delete (ClsPerlHost*) pPerlHost; + if (pPerlHost) + delete (ClsPerlHost*) pPerlHost; } diff --git a/NetWare/interface.h b/NetWare/interface.h index 2c9d46d75d..3718cfea62 100644 --- a/NetWare/interface.h +++ b/NetWare/interface.h @@ -27,19 +27,19 @@ class ClsPerlHost : public IPerlHost { public: - ClsPerlHost(void); - virtual ~ClsPerlHost(void); + ClsPerlHost(void); + virtual ~ClsPerlHost(void); - int VersionNumber(); + int VersionNumber(); - int PerlCreate(PerlInterpreter *my_perl); - int PerlParse(PerlInterpreter *my_perl, int argc, char** argv, char** env); - int PerlRun(PerlInterpreter *my_perl); - int PerlDestroy(PerlInterpreter *my_perl); - void PerlFree(PerlInterpreter *my_perl); + int PerlCreate(PerlInterpreter *my_perl); + int PerlParse(PerlInterpreter *my_perl, int argc, char** argv, char** env); + int PerlRun(PerlInterpreter *my_perl); + int PerlDestroy(PerlInterpreter *my_perl); + void PerlFree(PerlInterpreter *my_perl); - //bool RegisterWithThreadTable(void); - //bool UnregisterWithThreadTable(void); + //bool RegisterWithThreadTable(void); + //bool UnregisterWithThreadTable(void); }; diff --git a/NetWare/iperlhost.h b/NetWare/iperlhost.h index fe3dab7a34..946ee0a2c3 100644 --- a/NetWare/iperlhost.h +++ b/NetWare/iperlhost.h @@ -28,16 +28,16 @@ class IPerlHost { public: - virtual int VersionNumber() = 0; + virtual int VersionNumber() = 0; - virtual int PerlCreate(PerlInterpreter *my_perl) = 0; - virtual int PerlParse(PerlInterpreter *my_perl,int argc, char** argv, char** env) = 0; - virtual int PerlRun(PerlInterpreter *my_perl) = 0; - virtual int PerlDestroy(PerlInterpreter *my_perl) = 0; - virtual void PerlFree(PerlInterpreter *my_perl) = 0; + virtual int PerlCreate(PerlInterpreter *my_perl) = 0; + virtual int PerlParse(PerlInterpreter *my_perl,int argc, char** argv, char** env) = 0; + virtual int PerlRun(PerlInterpreter *my_perl) = 0; + virtual int PerlDestroy(PerlInterpreter *my_perl) = 0; + virtual void PerlFree(PerlInterpreter *my_perl) = 0; - //virtual bool RegisterWithThreadTable(void)=0; - //virtual bool UnregisterWithThreadTable(void)=0; + //virtual bool RegisterWithThreadTable(void)=0; + //virtual bool UnregisterWithThreadTable(void)=0; }; extern "C" IPerlHost* AllocStdPerl(); diff --git a/NetWare/netware.h b/NetWare/netware.h index c106476e28..af9e59936a 100644 --- a/NetWare/netware.h +++ b/NetWare/netware.h @@ -33,10 +33,10 @@ //structure that will be used by times routine. struct tms { - long tms_utime; - long tms_stime; - long tms_cutime; - long tms_cstime; + long tms_utime; + long tms_stime; + long tms_cutime; + long tms_cstime; }; #define PERL_GET_CONTEXT_DEFINED @@ -87,9 +87,9 @@ EXTERN_C void Perl_nw5_init(int *argcp, char ***argvp); // Below is called in Run.c file when a perl script executes/runs. #ifdef MPK_ON - #define PERL_ASYNC_CHECK() kYieldThread(); + #define PERL_ASYNC_CHECK() kYieldThread(); #else - #define PERL_ASYNC_CHECK() ThreadSwitch(); + #define PERL_ASYNC_CHECK() ThreadSwitch(); #endif diff --git a/NetWare/nw5.c b/NetWare/nw5.c index 46642a4d59..7db8ac0901 100644 --- a/NetWare/nw5.c +++ b/NetWare/nw5.c @@ -65,8 +65,8 @@ does not abend the server. void nw_abort(void) { - abort(); // Terminate the NLM application abnormally. - return; + abort(); // Terminate the NLM application abnormally. + return; } int @@ -84,8 +84,8 @@ nw_chmod(const char *path, int mode) void nw_clearerr(FILE *pf) { - if(pf) - clearerr(pf); + if(pf) + clearerr(pf); } int @@ -96,156 +96,156 @@ nw_close(int fd) nw_closedir(DIR *dirp) { - return (closedir(dirp)); + return (closedir(dirp)); } void nw_setbuf(FILE *pf, char *buf) { - if(pf) - setbuf(pf, buf); + if(pf) + setbuf(pf, buf); } int nw_setmode(FILE *fp, int mode) { /** - // Commented since a few abends were happening in fnFpSetMode - int *dummy = 0; - return(fnFpSetMode(fp, mode, dummy)); + // Commented since a few abends were happening in fnFpSetMode + int *dummy = 0; + return(fnFpSetMode(fp, mode, dummy)); **/ - int handle = -1; - errno = 0; + int handle = -1; + errno = 0; - handle = fileno(fp); - if (errno) - { - errno = 0; - return -1; - } - return setmode(handle, mode); + handle = fileno(fp); + if (errno) + { + errno = 0; + return -1; + } + return setmode(handle, mode); } int nw_setvbuf(FILE *pf, char *buf, int type, size_t size) { - if(pf) - return setvbuf(pf, buf, type, size); - else - return -1; + if(pf) + return setvbuf(pf, buf, type, size); + else + return -1; } unsigned int nw_sleep(unsigned int t) { - delay(t*1000); // Put the thread to sleep for 't' seconds. Initially 't' is passed in milliseconds. + delay(t*1000); // Put the thread to sleep for 't' seconds. Initially 't' is passed in milliseconds. return 0; } int nw_spawnvp(int mode, char *cmdname, char **argv) { - // There is no pass-around environment on NetWare so we throw that - // argument away for now. - - // The function "spawnvp" does not work in all situations. Loading - // edit.nlm seems to work, for example, but the name of the file - // to edit does not appear to get passed correctly. Another problem - // is that on Netware, P_WAIT does not really work reliably. It only - // works with NLMs built to use CLIB (according to Nile Thayne). - // NLMs such as EDIT that are written directly to the system have no - // way of running synchronously from another process. The whole - // architecture on NetWare seems pretty busted, so we just support it - // as best we can. - // - // The spawnvp function only launches NLMs, it will not execute a command; - // the NetWare "system" function is used for that purpose. Unfortunately, "system" - // always returns success whether the command is successful or not or even - // if the command was not found! To avoid ambiguity--you can have both an - // NLM named "perl" and a system command named "perl"--we need to - // force perl scripts to carry the word "load" when loading an NLM. This - // might be clearer anyway. - - int ret = 0; - int argc = 0; - - - if (stricmp(cmdname, LOAD_COMMAND) == 0) - { - if (argv[1] != NULL) - ret = spawnvp(mode, argv[1], &argv[1]); - } - else - { - int i=0; - while (argv[i] != '\0') - i++; - argc = i; - - fnSystemCommand(argv, argc); - } - - return ret; + // There is no pass-around environment on NetWare so we throw that + // argument away for now. + + // The function "spawnvp" does not work in all situations. Loading + // edit.nlm seems to work, for example, but the name of the file + // to edit does not appear to get passed correctly. Another problem + // is that on Netware, P_WAIT does not really work reliably. It only + // works with NLMs built to use CLIB (according to Nile Thayne). + // NLMs such as EDIT that are written directly to the system have no + // way of running synchronously from another process. The whole + // architecture on NetWare seems pretty busted, so we just support it + // as best we can. + // + // The spawnvp function only launches NLMs, it will not execute a command; + // the NetWare "system" function is used for that purpose. Unfortunately, "system" + // always returns success whether the command is successful or not or even + // if the command was not found! To avoid ambiguity--you can have both an + // NLM named "perl" and a system command named "perl"--we need to + // force perl scripts to carry the word "load" when loading an NLM. This + // might be clearer anyway. + + int ret = 0; + int argc = 0; + + + if (stricmp(cmdname, LOAD_COMMAND) == 0) + { + if (argv[1] != NULL) + ret = spawnvp(mode, argv[1], &argv[1]); + } + else + { + int i=0; + while (argv[i] != '\0') + i++; + argc = i; + + fnSystemCommand(argv, argc); + } + + return ret; } int nw_execv(char *cmdname, char **argv) { - return spawnvp(P_WAIT, cmdname, (char **)argv); + return spawnvp(P_WAIT, cmdname, (char **)argv); } int nw_execvp(char *cmdname, char **argv) { - return nw_spawnvp(P_WAIT, cmdname, (char **)argv); + return nw_spawnvp(P_WAIT, cmdname, (char **)argv); } int nw_stat(const char *path, struct stat *sbuf) { - return (stat(path, sbuf)); + return (stat(path, sbuf)); } FILE * nw_stderr(void) { - return (stderr); + return (stderr); } FILE * nw_stdin(void) { - return (stdin); + return (stdin); } FILE * nw_stdout() { - return (stdout); + return (stdout); } long nw_telldir(DIR *dirp) { - dTHX; - Perl_croak(aTHX_ "The telldir() function is not implemented on NetWare\n"); - return 0l; + dTHX; + Perl_croak(aTHX_ "The telldir() function is not implemented on NetWare\n"); + return 0l; } int nw_times(struct tms *timebuf) { - clock_t now = clock(); + clock_t now = clock(); - timebuf->tms_utime = now; - timebuf->tms_stime = 0; - timebuf->tms_cutime = 0; - timebuf->tms_cstime = 0; + timebuf->tms_utime = now; + timebuf->tms_stime = 0; + timebuf->tms_cutime = 0; + timebuf->tms_cstime = 0; - return 0; + return 0; } FILE* @@ -257,37 +257,37 @@ nw_tmpfile(void) int nw_uname(struct utsname *name) { - return(uname(name)); + return(uname(name)); } int nw_ungetc(int c, FILE *pf) { - if(pf) - return ungetc(c, pf); - else - return -1; + if(pf) + return ungetc(c, pf); + else + return -1; } int nw_unlink(const char *filename) { - return(unlink(filename)); + return(unlink(filename)); } int nw_utime(const char *filename, struct utimbuf *times) { - return(utime(filename, times)); + return(utime(filename, times)); } int nw_vfprintf(FILE *fp, const char *format, va_list args) { - if(fp) - return (vfprintf(fp, format, args)); - else - return -1; + if(fp) + return (vfprintf(fp, format, args)); + else + return -1; } int @@ -311,7 +311,7 @@ nw_write(int fd, const void *buf, unsigned int cnt) char * nw_crypt(const char *txt, const char *salt) { - dTHX; + dTHX; #ifdef HAVE_DES_FCRYPT dTHR; @@ -331,221 +331,221 @@ nw_dup(int fd) int nw_dup2(int fd1,int fd2) { - return dup2(fd1,fd2); + return dup2(fd1,fd2); } void* nw_dynaload(const char* filename) { - return NULL; + return NULL; } int nw_fclose(FILE *pf) { - if(pf) - return (fclose(pf)); - else - return -1; + if(pf) + return (fclose(pf)); + else + return -1; } FILE * nw_fdopen(int handle, const char *mode) { - return(fdopen(handle, mode)); + return(fdopen(handle, mode)); } int nw_feof(FILE *fp) { - if(fp) - return (feof(fp)); - else - return -1; + if(fp) + return (feof(fp)); + else + return -1; } int nw_ferror(FILE *fp) { - if(fp) - return (ferror(fp)); - else - return -1; + if(fp) + return (ferror(fp)); + else + return -1; } int nw_fflush(FILE *pf) { - if(pf) - return fflush(pf); - else - return -1; + if(pf) + return fflush(pf); + else + return -1; } int nw_fgetpos(FILE *pf, fpos_t *p) { - if(pf) - return fgetpos(pf, p); - else - return -1; + if(pf) + return fgetpos(pf, p); + else + return -1; } char* nw_fgets(char *s, int n, FILE *pf) { - if(pf) - return(fgets(s, n, pf)); - else - return NULL; + if(pf) + return(fgets(s, n, pf)); + else + return NULL; } int nw_fileno(FILE *pf) { - if(pf) - return fileno(pf); - else - return -1; + if(pf) + return fileno(pf); + else + return -1; } int nw_flock(int fd, int oper) { - dTHX; - Perl_croak(aTHX_ "The flock() function is not implemented on NetWare\n"); - return 0; + dTHX; + Perl_croak(aTHX_ "The flock() function is not implemented on NetWare\n"); + return 0; } FILE * nw_fopen(const char *filename, const char *mode) { - return (fopen(filename, mode)); + return (fopen(filename, mode)); } int nw_fputc(int c, FILE *pf) { - if(pf) - return fputc(c,pf); - else - return -1; + if(pf) + return fputc(c,pf); + else + return -1; } int nw_fputs(const char *s, FILE *pf) { - if(pf) - return fputs(s, pf); - else - return -1; + if(pf) + return fputs(s, pf); + else + return -1; } size_t nw_fread(void *buf, size_t size, size_t count, FILE *fp) { - if(fp) - return fread(buf, size, count, fp); - else - return -1; + if(fp) + return fread(buf, size, count, fp); + else + return -1; } FILE * nw_freopen(const char *path, const char *mode, FILE *stream) { - if(stream) - return freopen(path, mode, stream); - else - return NULL; + if(stream) + return freopen(path, mode, stream); + else + return NULL; } int nw_fseek(FILE *pf, long offset, int origin) { - if(pf) - return (fseek(pf, offset, origin)); - else - return -1; + if(pf) + return (fseek(pf, offset, origin)); + else + return -1; } int nw_fsetpos(FILE *pf, const fpos_t *p) { - if(pf) - return fsetpos(pf, p); - else - return -1; + if(pf) + return fsetpos(pf, p); + else + return -1; } long nw_ftell(FILE *pf) { - if(pf) - return ftell(pf); - else - return -1; + if(pf) + return ftell(pf); + else + return -1; } size_t nw_fwrite(const void *buf, size_t size, size_t count, FILE *fp) { - if(fp) - return fwrite(buf, size, count, fp); - else - return -1; + if(fp) + return fwrite(buf, size, count, fp); + else + return -1; } long nw_get_osfhandle(int fd) { - return 0l; + return 0l; } int nw_getc(FILE *pf) { - if(pf) - return getc(pf); - else - return -1; + if(pf) + return getc(pf); + else + return -1; } int nw_putc(int c, FILE *pf) { - if(pf) - return putc(c,pf); - else - return -1; + if(pf) + return putc(c,pf); + else + return -1; } int nw_fgetc(FILE *pf) { - if(pf) - return fgetc(pf); - else - return -1; + if(pf) + return fgetc(pf); + else + return -1; } int nw_getpid(void) { - return GetThreadGroupID(); + return GetThreadGroupID(); } int nw_kill(int pid, int sig) { - return 0; + return 0; } int nw_link(const char *oldname, const char *newname) { - return 0; + return 0; } long @@ -569,165 +569,165 @@ nw_rmdir(const char *dir) DIR * nw_opendir(const char *filename) { - char *buff = NULL; - int len = 0; - DIR *ret = NULL; - - len = strlen(filename); - buff = malloc(len + 5); - if (buff) { - strcpy(buff, filename); - if (buff[len-1]=='/' || buff[len-1]=='\\') { - buff[--len] = 0; - } - strcpy(buff+len, "/*.*"); - ret = opendir(buff); - free (buff); - buff = NULL; - return ret; - } else { - return NULL; - } + char *buff = NULL; + int len = 0; + DIR *ret = NULL; + + len = strlen(filename); + buff = malloc(len + 5); + if (buff) { + strcpy(buff, filename); + if (buff[len-1]=='/' || buff[len-1]=='\\') { + buff[--len] = 0; + } + strcpy(buff+len, "/*.*"); + ret = opendir(buff); + free (buff); + buff = NULL; + return ret; + } else { + return NULL; + } } int nw_open(const char *path, int flag, ...) { - va_list ap; - int pmode = -1; + va_list ap; + int pmode = -1; - va_start(ap, flag); + va_start(ap, flag); pmode = va_arg(ap, int); va_end(ap); - if (stricmp(path, "/dev/null")==0) - path = "NWNUL"; + if (stricmp(path, "/dev/null")==0) + path = "NWNUL"; - return open(path, flag, pmode); + return open(path, flag, pmode); } int nw_open_osfhandle(long handle, int flags) { - return 0; + return 0; } unsigned long nw_os_id(void) { - return 0l; + return 0l; } int nw_Pipe(int* a, int* e) { - int ret = 0; + int ret = 0; - errno = 0; - ret = pipe(a); - if(errno) - e = &errno; + errno = 0; + ret = pipe(a); + if(errno) + e = &errno; - return ret; + return ret; } FILE* nw_Popen(char* command, char* mode, int* e) { - int i = -1; - - FILE* ret = NULL; - PTEMPPIPEFILE ptpf = NULL; - - // this callback is supposed to call _popen, which spawns an - // asynchronous command and opens a pipe to it. The returned - // file handle can be read or written to; if read, it represents - // stdout of the called process and will return EOF when the - // called process finishes. If written to, it represents stdin - // of the called process. Naturally _popen is not available on - // NetWare so we must do some fancy stuff to simulate it. We will - // redirect to and from temp files; this has the side effect - // of having to run the process synchronously rather than - // asynchronously. This means that you will only be able to do - // this with CLIB NLMs built to run on the calling thread. - - errno = 0; - - ptpf1[iPopenCount] = (PTEMPPIPEFILE) malloc(sizeof(TEMPPIPEFILE)); - if (!ptpf1[iPopenCount]) - return NULL; - - ptpf = ptpf1[iPopenCount]; - iPopenCount ++; - if(iPopenCount > MAX_PIPE_RECURSION) - iPopenCount = MAX_PIPE_RECURSION; // Limit to the max no of pipes to be open recursively. - - fnTempPipeFile(ptpf); - ret = fnPipeFileOpen((PTEMPPIPEFILE) ptpf, (char *) command, (char *) mode); - if (ret) - File1[iPopenCount-1] = ret; // Store the obtained Pipe file handle. - else - { // Pipe file not obtained. So free the allocated memory. - if(ptpf1[iPopenCount-1]) - { - free(ptpf1[iPopenCount-1]); - ptpf1[iPopenCount-1] = NULL; - ptpf = NULL; - iPopenCount --; - } - } - - if (errno) - e = &errno; - - return ret; + int i = -1; + + FILE* ret = NULL; + PTEMPPIPEFILE ptpf = NULL; + + // this callback is supposed to call _popen, which spawns an + // asynchronous command and opens a pipe to it. The returned + // file handle can be read or written to; if read, it represents + // stdout of the called process and will return EOF when the + // called process finishes. If written to, it represents stdin + // of the called process. Naturally _popen is not available on + // NetWare so we must do some fancy stuff to simulate it. We will + // redirect to and from temp files; this has the side effect + // of having to run the process synchronously rather than + // asynchronously. This means that you will only be able to do + // this with CLIB NLMs built to run on the calling thread. + + errno = 0; + + ptpf1[iPopenCount] = (PTEMPPIPEFILE) malloc(sizeof(TEMPPIPEFILE)); + if (!ptpf1[iPopenCount]) + return NULL; + + ptpf = ptpf1[iPopenCount]; + iPopenCount ++; + if(iPopenCount > MAX_PIPE_RECURSION) + iPopenCount = MAX_PIPE_RECURSION; // Limit to the max no of pipes to be open recursively. + + fnTempPipeFile(ptpf); + ret = fnPipeFileOpen((PTEMPPIPEFILE) ptpf, (char *) command, (char *) mode); + if (ret) + File1[iPopenCount-1] = ret; // Store the obtained Pipe file handle. + else + { // Pipe file not obtained. So free the allocated memory. + if(ptpf1[iPopenCount-1]) + { + free(ptpf1[iPopenCount-1]); + ptpf1[iPopenCount-1] = NULL; + ptpf = NULL; + iPopenCount --; + } + } + + if (errno) + e = &errno; + + return ret; } int nw_Pclose(FILE* file, int* e) { - int i=0, j=0; + int i=0, j=0; - errno = 0; + errno = 0; - if(file) - { - if(iPopenCount > 0) - { - for (i=0; i<iPopenCount; i++) - { - if(File1[i] == file) - { - // Delete the memory allocated corresponding to the file handle passed-in and - // also close the file corresponding to the file handle passed-in! - if(ptpf1[i]) - { - fnPipeFileClose(ptpf1[i]); + if(file) + { + if(iPopenCount > 0) + { + for (i=0; i<iPopenCount; i++) + { + if(File1[i] == file) + { + // Delete the memory allocated corresponding to the file handle passed-in and + // also close the file corresponding to the file handle passed-in! + if(ptpf1[i]) + { + fnPipeFileClose(ptpf1[i]); - free(ptpf1[i]); - ptpf1[i] = NULL; - } + free(ptpf1[i]); + ptpf1[i] = NULL; + } - fclose(File1[i]); - File1[i] = NULL; + fclose(File1[i]); + File1[i] = NULL; - break; - } - } + break; + } + } - // Rearrange the file pointer array - for(j=i; j<(iPopenCount-1); j++) - { - File1[j] = File1[j+1]; - ptpf1[j] = ptpf1[j+1]; - } - iPopenCount--; - } - } - else - return -1; + // Rearrange the file pointer array + for(j=i; j<(iPopenCount-1); j++) + { + File1[j] = File1[j+1]; + ptpf1[j] = ptpf1[j+1]; + } + iPopenCount--; + } + } + else + return -1; - if (errno) - e = &errno; + if (errno) + e = &errno; - return 0; + return 0; } @@ -740,8 +740,8 @@ nw_vprintf(const char *format, va_list args) int nw_printf(const char *format, ...) { - - va_list marker; + + va_list marker; va_start(marker, format); /* Initialize variable arguments. */ return (vprintf(format, marker)); @@ -750,45 +750,45 @@ nw_printf(const char *format, ...) int nw_read(int fd, void *buf, unsigned int cnt) { - return read(fd, buf, cnt); + return read(fd, buf, cnt); } struct direct * nw_readdir(DIR *dirp) { - DIR* ret=NULL; + DIR* ret=NULL; - ret = readdir(dirp); - if(ret) - return((struct direct *)ret); - return NULL; + ret = readdir(dirp); + if(ret) + return((struct direct *)ret); + return NULL; } int nw_rename(const char *oname, const char *newname) { - return(rename(oname,newname)); + return(rename(oname,newname)); } void nw_rewinddir(DIR *dirp) { - dTHX; - Perl_croak(aTHX_ "The rewinddir() function is not implemented on NetWare\n"); + dTHX; + Perl_croak(aTHX_ "The rewinddir() function is not implemented on NetWare\n"); } void nw_rewind(FILE *pf) { - if(pf) - rewind(pf); + if(pf) + rewind(pf); } void nw_seekdir(DIR *dirp, long loc) { - dTHX; - Perl_croak(aTHX_ "The seekdir() function is not implemented on NetWare\n"); + dTHX; + Perl_croak(aTHX_ "The seekdir() function is not implemented on NetWare\n"); } int * @@ -800,31 +800,31 @@ nw_errno(void) char *** nw_environ(void) { - return ((char ***)nw_getenviron()); + return ((char ***)nw_getenviron()); } char * nw_strerror(int e) { - return (strerror(e)); + return (strerror(e)); } int nw_isatty(int fd) { - return(isatty(fd)); + return(isatty(fd)); } char * nw_mktemp(char *Template) { - return (fnMy_MkTemp(Template)); + return (fnMy_MkTemp(Template)); } int nw_chsize(int handle, long size) { - return(chsize(handle,size)); + return(chsize(handle,size)); } #ifdef HAVE_INTERP_INTERN @@ -863,7 +863,7 @@ Perl_nw5_init(int *argcp, char ***argvp) PerlInterpreter * perl_clone_host(PerlInterpreter* proto_perl, UV flags) { - // Perl Clone is not implemented on NetWare. + // Perl Clone is not implemented on NetWare. return NULL; } #endif @@ -873,33 +873,33 @@ perl_clone_host(PerlInterpreter* proto_perl, UV flags) int execv(char *cmdname, char **argv) { - // This feature needs to be implemented. - // _asm is commented out since it goes into the internal debugger. + // This feature needs to be implemented. + // _asm is commented out since it goes into the internal debugger. // _asm {int 3}; - return(0); + return(0); } int execvp(char *cmdname, char **argv) { - // This feature needs to be implemented. - // _asm is commented out since it goes into the internal debugger. + // This feature needs to be implemented. + // _asm is commented out since it goes into the internal debugger. // _asm {int 3}; - return(0); + return(0); } int do_aspawn(void *vreally, void **vmark, void **vsp) { - // This feature needs to be implemented. - // _asm is commented out since it goes into the internal debugger. + // This feature needs to be implemented. + // _asm is commented out since it goes into the internal debugger. // _asm {int 3}; //// return(0); - // This below code is required for system() call. - // Otherwise system() does not work on NetWare. - // Ananth, 3 Sept 2001 + // This below code is required for system() call. + // Otherwise system() does not work on NetWare. + // Ananth, 3 Sept 2001 dTHX; SV *really = (SV*)vreally; @@ -913,47 +913,47 @@ do_aspawn(void *vreally, void **vmark, void **vsp) if (sp <= mark) - return -1; + return -1; - nw_perlshell_items = 0; // No Shell + nw_perlshell_items = 0; // No Shell // Newx(argv, (sp - mark) + nw_perlshell_items + 3, char*); // In the old code of 5.6.1 Newx(argv, (sp - mark) + nw_perlshell_items + 2, char*); if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { - ++mark; - flag = SvIVx(*mark); + ++mark; + flag = SvIVx(*mark); } while (++mark <= sp) { - if (*mark && (str = (char *)SvPV_nolen(*mark))) - { - argv[index] = str; - index++; - } - else - { - argv[index] = ""; + if (*mark && (str = (char *)SvPV_nolen(*mark))) + { + argv[index] = str; + index++; + } + else + { + argv[index] = ""; // argv[index] = '\0'; - index++; + index++; } - } + } argv[index] = '\0'; - index++; + index++; status = nw_spawnvp(flag, - (char*)(really ? SvPV_nolen(really) : argv[0]), - (char**)argv); + (char*)(really ? SvPV_nolen(really) : argv[0]), + (char**)argv); if (flag != P_NOWAIT) { - if (status < 0) { + if (status < 0) { // dTHR; // Only in old code of 5.6.1 - if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno)); - status = 255 * 256; - } - else - status *= 256; - PL_statusvalue = status; + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno)); + status = 255 * 256; + } + else + status *= 256; + PL_statusvalue = status; } Safefree(argv); @@ -963,12 +963,12 @@ do_aspawn(void *vreally, void **vmark, void **vsp) int do_spawn2(char *cmd, int exectype) { - // This feature needs to be implemented. - // _asm is commented out since it goes into the internal debugger. + // This feature needs to be implemented. + // _asm is commented out since it goes into the internal debugger. // _asm {int 3}; //// return(0); - // Below added to make system() work for NetWare + // Below added to make system() work for NetWare dTHX; char **a; @@ -981,80 +981,80 @@ do_spawn2(char *cmd, int exectype) /* Save an extra exec if possible. See if there are shell * metacharacters in it */ if (!has_shell_metachars(cmd)) { - Newx(argv, strlen(cmd) / 2 + 2, char*); - Newx(cmd2, strlen(cmd) + 1, char); - strcpy(cmd2, cmd); - a = argv; - for (s = cmd2; *s;) { - while (*s && isSPACE(*s)) - s++; - if (*s) - *(a++) = s; - while (*s && !isSPACE(*s)) - s++; - if (*s) - *s++ = '\0'; - } - *a = NULL; - if (argv[0]) { - switch (exectype) { - case EXECF_SPAWN: - status = nw_spawnvp(P_WAIT, argv[0], (char **)argv); - break; - - case EXECF_SPAWN_NOWAIT: - status = nw_spawnvp(P_NOWAIT, argv[0], (char **)argv); - break; - - case EXECF_EXEC: - status = nw_execvp(argv[0], (char **)argv); - break; - } - if (status != -1 || errno == 0) - needToTry = FALSE; - } - Safefree(argv); - Safefree(cmd2); + Newx(argv, strlen(cmd) / 2 + 2, char*); + Newx(cmd2, strlen(cmd) + 1, char); + strcpy(cmd2, cmd); + a = argv; + for (s = cmd2; *s;) { + while (*s && isSPACE(*s)) + s++; + if (*s) + *(a++) = s; + while (*s && !isSPACE(*s)) + s++; + if (*s) + *s++ = '\0'; + } + *a = NULL; + if (argv[0]) { + switch (exectype) { + case EXECF_SPAWN: + status = nw_spawnvp(P_WAIT, argv[0], (char **)argv); + break; + + case EXECF_SPAWN_NOWAIT: + status = nw_spawnvp(P_NOWAIT, argv[0], (char **)argv); + break; + + case EXECF_EXEC: + status = nw_execvp(argv[0], (char **)argv); + break; + } + if (status != -1 || errno == 0) + needToTry = FALSE; + } + Safefree(argv); + Safefree(cmd2); } if (needToTry) { - char **argv = NULL; - int i = -1; - - Newx(argv, nw_perlshell_items + 2, char*); - while (++i < nw_perlshell_items) - argv[i] = nw_perlshell_vec[i]; - argv[i++] = cmd; - argv[i] = NULL; - switch (exectype) { - case EXECF_SPAWN: - status = nw_spawnvp(P_WAIT, argv[0], (char **)argv); - break; - - case EXECF_SPAWN_NOWAIT: - status = nw_spawnvp(P_NOWAIT, argv[0], (char **)argv); - break; - - case EXECF_EXEC: - status = nw_execvp(argv[0], (char **)argv); - break; - } - cmd = argv[0]; - Safefree(argv); + char **argv = NULL; + int i = -1; + + Newx(argv, nw_perlshell_items + 2, char*); + while (++i < nw_perlshell_items) + argv[i] = nw_perlshell_vec[i]; + argv[i++] = cmd; + argv[i] = NULL; + switch (exectype) { + case EXECF_SPAWN: + status = nw_spawnvp(P_WAIT, argv[0], (char **)argv); + break; + + case EXECF_SPAWN_NOWAIT: + status = nw_spawnvp(P_NOWAIT, argv[0], (char **)argv); + break; + + case EXECF_EXEC: + status = nw_execvp(argv[0], (char **)argv); + break; + } + cmd = argv[0]; + Safefree(argv); } if (exectype != EXECF_SPAWN_NOWAIT) { - if (status < 0) { - dTHR; - if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", - (exectype == EXECF_EXEC ? "exec" : "spawn"), - cmd, strerror(errno)); - status = 255 * 256; - } - else - status *= 256; - PL_statusvalue = status; + if (status < 0) { + dTHR; + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", + (exectype == EXECF_EXEC ? "exec" : "spawn"), + cmd, strerror(errno)); + status = 255 * 256; + } + else + status *= 256; + PL_statusvalue = status; } return (status); } @@ -1078,31 +1078,31 @@ has_shell_metachars(char *ptr) * Shell variable interpolation (%VAR%) can also happen inside strings. */ while (*ptr) { - switch(*ptr) { - case '%': - return TRUE; - case '\'': - case '\"': - if (inquote) { - if (quote == *ptr) { - inquote = 0; - quote = '\0'; - } - } - else { - quote = *ptr; - inquote++; - } - break; - case '>': - case '<': - case '|': - if (!inquote) - return TRUE; - default: - break; - } - ++ptr; + switch(*ptr) { + case '%': + return TRUE; + case '\'': + case '\"': + if (inquote) { + if (quote == *ptr) { + inquote = 0; + quote = '\0'; + } + } + else { + quote = *ptr; + inquote++; + } + break; + case '>': + case '<': + case '|': + if (!inquote) + return TRUE; + default: + break; + } + ++ptr; } return FALSE; } @@ -1110,7 +1110,7 @@ has_shell_metachars(char *ptr) int fork(void) { - return 0; + return 0; } @@ -1118,5 +1118,5 @@ fork(void) int Perl_Ireentrant_buffer_ptr(aTHX) { - return 0; + return 0; } diff --git a/NetWare/nw5sck.c b/NetWare/nw5sck.c index 35dee92bf1..217313e223 100644 --- a/NetWare/nw5sck.c +++ b/NetWare/nw5sck.c @@ -57,50 +57,50 @@ nw_ntohs(u_short netshort) SOCKET nw_accept(SOCKET s, struct sockaddr *addr, int *addrlen) { - return ((SOCKET)(accept(s, addr, addrlen))); + return ((SOCKET)(accept(s, addr, addrlen))); } int nw_bind(SOCKET s, const struct sockaddr *addr, int addrlen) { - return ((int)bind(s, (struct sockaddr *)addr, addrlen)); + return ((int)bind(s, (struct sockaddr *)addr, addrlen)); } int nw_connect(SOCKET s, const struct sockaddr *addr, int addrlen) { - return((int)connect(s, (struct sockaddr *)addr, addrlen)); + return((int)connect(s, (struct sockaddr *)addr, addrlen)); } void nw_endhostent() { - endhostent(); + endhostent(); } void nw_endnetent() { - endnetent(); + endnetent(); } void nw_endprotoent() { - endprotoent(); + endprotoent(); } void nw_endservent() { - endservent(); + endservent(); } struct hostent * nw_gethostent() { - return(gethostent()); + return(gethostent()); } struct netent * @@ -118,7 +118,7 @@ nw_getprotoent(void) struct hostent * nw_gethostbyname(const char *name) { - return(gethostbyname((char*)name)); + return(gethostbyname((char*)name)); } int @@ -130,13 +130,13 @@ nw_gethostname(char *name, int len) struct hostent * nw_gethostbyaddr(const char *addr, int len, int type) { - return(gethostbyaddr((char*)addr, len, type)); + return(gethostbyaddr((char*)addr, len, type)); } struct netent * nw_getnetbyaddr(long net, int type) { - return(getnetbyaddr(net,type)); + return(getnetbyaddr(net,type)); } struct netent * @@ -148,19 +148,19 @@ nw_getnetbyname(char *name) int nw_getpeername(SOCKET s, struct sockaddr *addr, int *addrlen) { - return((int)getpeername(s, addr, addrlen)); + return((int)getpeername(s, addr, addrlen)); } struct protoent * nw_getprotobyname(const char *name) { - return ((struct protoent *)getprotobyname((char*)name)); + return ((struct protoent *)getprotobyname((char*)name)); } struct protoent * nw_getprotobynumber(int num) { - return ((struct protoent *)getprotobynumber(num)); + return ((struct protoent *)getprotobynumber(num)); } struct servent * @@ -186,7 +186,7 @@ void nw_sethostent(int stayopen) { #ifdef HAS_SETHOSTENT - sethostent(stayopen); + sethostent(stayopen); #endif } @@ -194,7 +194,7 @@ void nw_setnetent(int stayopen) { #ifdef HAS_SETNETENT - setnetent(stayopen); + setnetent(stayopen); #endif } @@ -202,7 +202,7 @@ void nw_setprotoent(int stayopen) { #ifdef HAS_SETPROTENT - setprotoent(stayopen); + setprotoent(stayopen); #endif } @@ -210,26 +210,26 @@ void nw_setservent(int stayopen) { #ifdef HAS_SETSERVENT - setservent(stayopen); + setservent(stayopen); #endif } int nw_setsockopt(SOCKET s, int level, int optname, const char* optval, int optlen) { - return setsockopt(s, level, optname, (char*)optval, optlen); + return setsockopt(s, level, optname, (char*)optval, optlen); } int nw_getsockname(SOCKET s, struct sockaddr *addr, int *addrlen) { - return getsockname(s, addr, addrlen); + return getsockname(s, addr, addrlen); } int nw_getsockopt(SOCKET s, int level, int optname, char *optval, int *optlen) { - return ((int)getsockopt(s, level, optname, optval, optlen)); + return ((int)getsockopt(s, level, optname, optval, optlen)); } unsigned long @@ -253,9 +253,9 @@ nw_socket(int af, int type, int protocol) s = socket(af, type, protocol); #else if((s = socket(af, type, protocol)) == INVALID_SOCKET) - //errno = WSAGetLastError(); + //errno = WSAGetLastError(); else - s = s; + s = s; #endif /* USE_SOCKETS_AS_HANDLES */ return s; @@ -270,18 +270,18 @@ nw_listen(SOCKET s, int backlog) int nw_send(SOCKET s, const char *buf, int len, int flags) { - return(send(s,(char*)buf,len,flags)); + return(send(s,(char*)buf,len,flags)); } int nw_recv(SOCKET s, char *buf, int len, int flags) { - return (recv(s, buf, len, flags)); + return (recv(s, buf, len, flags)); } int nw_sendto(SOCKET s, const char *buf, int len, int flags, - const struct sockaddr *to, int tolen) + const struct sockaddr *to, int tolen) { return(sendto(s, (char*)buf, len, flags, (struct sockaddr *)to, tolen)); } @@ -293,16 +293,16 @@ nw_recvfrom(SOCKET s, char *buf, int len, int flags, struct sockaddr *from, int int frombufsize = *fromlen; r = recvfrom(s, buf, len, flags, from, fromlen); - //Not sure if the is required - chksgp + //Not sure if the is required - chksgp if (r && frombufsize == *fromlen) - (void)nw_getpeername(s, from, fromlen); + (void)nw_getpeername(s, from, fromlen); return r; } int nw_select(int nfds, fd_set* rd, fd_set* wr, fd_set* ex, const struct timeval* timeout) { - return(select(nfds, rd, wr, ex, (struct timeval*)timeout)); + return(select(nfds, rd, wr, ex, (struct timeval*)timeout)); } int diff --git a/NetWare/nw5thread.c b/NetWare/nw5thread.c index abedb5c2da..3b9d8304de 100644 --- a/NetWare/nw5thread.c +++ b/NetWare/nw5thread.c @@ -36,7 +36,7 @@ Perl_set_context(void *t) # ifdef USE_DECLSPEC_THREAD Perl_current_context = t; # else - fnAddThreadCtx(PL_thr_key, t); + fnAddThreadCtx(PL_thr_key, t); # endif #endif } @@ -49,7 +49,7 @@ Perl_get_context(void) # ifdef USE_DECLSPEC_THREAD return Perl_current_context; # else - return(fnGetThreadCtx(PL_thr_key)); + return(fnGetThreadCtx(PL_thr_key)); # endif #else return NULL; @@ -63,12 +63,12 @@ Remove_Thread_Ctx(void) { #if defined(USE_ITHREADS) # ifdef USE_DECLSPEC_THREAD - return TRUE; + return TRUE; # else - return(fnRemoveThreadCtx(PL_thr_key)); + return(fnRemoveThreadCtx(PL_thr_key)); # endif # else - return TRUE; + return TRUE; #endif } diff --git a/NetWare/nw5thread.h b/NetWare/nw5thread.h index e7d86757ee..40cbdc3aac 100644 --- a/NetWare/nw5thread.h +++ b/NetWare/nw5thread.h @@ -37,10 +37,10 @@ typedef struct nw_cond { long waiters; unsigned int sem; } perl_cond; extern "C" { #endif - #include <mpktypes.h> - #include <mpkapis.h> - #define kSUCCESS (0) - #define ERROR_INVALID_MUTEX (0x1010) + #include <mpktypes.h> + #include <mpkapis.h> + #define kSUCCESS (0) + #define ERROR_INVALID_MUTEX (0x1010) #ifdef __cplusplus } @@ -55,34 +55,34 @@ extern "C" typedef MUTEX perl_mutex; # define MUTEX_INIT(m) \ STMT_START { \ - /*if ((*(m) = kMutexAlloc("NetWarePerlMutex")) == NULL) */\ - /*Perl_croak_nocontext("panic: MUTEX_ALLOC"); */\ - /*ConsolePrintf("Mutex Init %d\n",*(m)); */\ + /*if ((*(m) = kMutexAlloc("NetWarePerlMutex")) == NULL) */\ + /*Perl_croak_nocontext("panic: MUTEX_ALLOC"); */\ + /*ConsolePrintf("Mutex Init %d\n",*(m)); */\ } STMT_END # define MUTEX_LOCK(m) \ STMT_START { \ - /*ConsolePrintf("Mutex lock %d\n",*(m)); */\ - /*if (kMutexLock(*(m)) == ERROR_INVALID_MUTEX) */\ - /*Perl_croak_nocontext("panic: MUTEX_LOCK"); */\ + /*ConsolePrintf("Mutex lock %d\n",*(m)); */\ + /*if (kMutexLock(*(m)) == ERROR_INVALID_MUTEX) */\ + /*Perl_croak_nocontext("panic: MUTEX_LOCK"); */\ } STMT_END # define MUTEX_UNLOCK(m) \ STMT_START { \ - /*ConsolePrintf("Mutex unlock %d\n",*(m)); */\ - /*if (kMutexUnlock(*(m)) != kSUCCESS) \ - Perl_croak_nocontext("panic: MUTEX_UNLOCK"); */\ + /*ConsolePrintf("Mutex unlock %d\n",*(m)); */\ + /*if (kMutexUnlock(*(m)) != kSUCCESS) \ + Perl_croak_nocontext("panic: MUTEX_UNLOCK"); */\ } STMT_END # define MUTEX_DESTROY(m) \ STMT_START { \ - /*ConsolePrintf("Mutex Destroy %d\n",*(m)); */\ - /*if (kMutexWaitCount(*(m)) == 0 ) */\ - /*{ */\ - /*PERL_SET_INTERP(NULL); *//*newly added CHKSGP???*/ \ - /*if (kMutexFree(*(m)) != kSUCCESS) */ \ - /*Perl_croak_nocontext("panic: MUTEX_FREE"); */\ - /*} */\ + /*ConsolePrintf("Mutex Destroy %d\n",*(m)); */\ + /*if (kMutexWaitCount(*(m)) == 0 ) */\ + /*{ */\ + /*PERL_SET_INTERP(NULL); *//*newly added CHKSGP???*/ \ + /*if (kMutexFree(*(m)) != kSUCCESS) */ \ + /*Perl_croak_nocontext("panic: MUTEX_FREE"); */\ + /*} */\ } STMT_END #else @@ -100,56 +100,56 @@ typedef unsigned long perl_mutex; //For now let us just see when this happens -sgp. #define COND_INIT(c) \ STMT_START { \ - /*ConsolePrintf("In COND_INIT\n"); */\ + /*ConsolePrintf("In COND_INIT\n"); */\ } STMT_END /* (c)->waiters = 0; \ - (c)->sem = OpenLocalSemaphore (0); \ - if ((c)->sem == NULL) \ - Perl_croak_nocontext("panic: COND_INIT (%ld)",errno); \*/ + (c)->sem = OpenLocalSemaphore (0); \ + if ((c)->sem == NULL) \ + Perl_croak_nocontext("panic: COND_INIT (%ld)",errno); \*/ #define COND_SIGNAL(c) \ STMT_START { \ - /*ConsolePrintf("In COND_SIGNAL\n"); */\ + /*ConsolePrintf("In COND_SIGNAL\n"); */\ } STMT_END /*if ((c)->waiters > 0 && \ - SignalLocalSemaphore((c)->sem) != 0) \ - Perl_croak_nocontext("panic: COND_SIGNAL (%ld)",errno); \*/ + SignalLocalSemaphore((c)->sem) != 0) \ + Perl_croak_nocontext("panic: COND_SIGNAL (%ld)",errno); \*/ #define COND_BROADCAST(c) \ STMT_START { \ - /*ConsolePrintf("In COND_BROADCAST\n"); */\ + /*ConsolePrintf("In COND_BROADCAST\n"); */\ } STMT_END - /*if ((c)->waiters > 0 ) { \ - int count; \ - for(count=0; count<(c)->waiters; count++) { \ - if(SignalLocalSemaphore((c)->sem) != 0) \ - Perl_croak_nocontext("panic: COND_BROADCAST (%ld)",GetLastError());\ - } \ - } \*/ + /*if ((c)->waiters > 0 ) { \ + int count; \ + for(count=0; count<(c)->waiters; count++) { \ + if(SignalLocalSemaphore((c)->sem) != 0) \ + Perl_croak_nocontext("panic: COND_BROADCAST (%ld)",GetLastError());\ + } \ + } \*/ #define COND_WAIT(c, m) \ STMT_START { \ - /*ConsolePrintf("In COND_WAIT\n"); */\ + /*ConsolePrintf("In COND_WAIT\n"); */\ } STMT_END #define COND_DESTROY(c) \ STMT_START { \ - /*ConsolePrintf("In COND_DESTROY\n"); */\ + /*ConsolePrintf("In COND_DESTROY\n"); */\ } STMT_END /* (c)->waiters = 0; \ - if (CloseLocalSemaphore((c)->sem) != 0) \ - Perl_croak_nocontext("panic: COND_DESTROY (%ld)",errno); \*/ + if (CloseLocalSemaphore((c)->sem) != 0) \ + Perl_croak_nocontext("panic: COND_DESTROY (%ld)",errno); \*/ #if 0 #define DETACH(t) \ STMT_START { \ - if (CloseHandle((t)->self) == 0) { \ - MUTEX_UNLOCK(&(t)->mutex); \ - Perl_croak_nocontext("panic: DETACH"); \ - } \ + if (CloseHandle((t)->self) == 0) { \ + MUTEX_UNLOCK(&(t)->mutex); \ + Perl_croak_nocontext("panic: DETACH"); \ + } \ } STMT_END #endif //#if 0 @@ -172,7 +172,7 @@ extern __declspec(thread) void *PL_current_context; //See the comment at the end of file nw5thread.c as to why PL_thr_key is not assigned - sgp #define ALLOC_THREAD_KEY \ STMT_START { \ - fnInitializeThreadCtx(); \ + fnInitializeThreadCtx(); \ } STMT_END diff --git a/NetWare/nwhashcls.h b/NetWare/nwhashcls.h index 55ff200220..ba18053ee2 100644 --- a/NetWare/nwhashcls.h +++ b/NetWare/nwhashcls.h @@ -22,8 +22,8 @@ struct HASHNODE { - void *data; - struct HASHNODE *next; + void *data; + struct HASHNODE *next; }; typedef void (*HASHFORALLFUN)(void *, void *); @@ -31,22 +31,22 @@ typedef void (*HASHFORALLFUN)(void *, void *); class NWPerlHashList { private: - HASHNODE* MemListHash[BUCKET_SIZE]; + HASHNODE* MemListHash[BUCKET_SIZE]; void removeAll() const; public: - ~NWPerlHashList(); - NWPerlHashList(); - int insert(void *lData); - int remove(void *lData); + ~NWPerlHashList(); + NWPerlHashList(); + int insert(void *lData); + int remove(void *lData); void forAll( void (*)(void *, void*), void * ) const; }; struct KEYHASHNODE { - void *key; - void *data; - KEYHASHNODE *next; + void *key; + void *data; + KEYHASHNODE *next; }; /** @@ -55,16 +55,16 @@ typedef void (*KEYHASHFORALLFUN)(void *, void *); class NWPerlKeyHashList { private: - KEYHASHNODE* MemListHash[BUCKET_SIZE]; + KEYHASHNODE* MemListHash[BUCKET_SIZE]; void removeAll() const; public: - ~NWPerlKeyHashList(); - NWPerlKeyHashList(); - int insert(void *key, void *lData); - int remove(void *key); + ~NWPerlKeyHashList(); + NWPerlKeyHashList(); + int insert(void *key, void *lData); + int remove(void *key); void forAll( void (*)(void *, void*), void * ) const; - int find(void *key, void **pData); + int find(void *key, void **pData); }; **/ diff --git a/NetWare/nwperlhost.h b/NetWare/nwperlhost.h index c69e554489..e011bd351f 100644 --- a/NetWare/nwperlhost.h +++ b/NetWare/nwperlhost.h @@ -52,10 +52,10 @@ class CPerlHost public: CPerlHost(void); CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, - struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, - struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, - struct IPerlDir** ppDir, struct IPerlSock** ppSock, - struct IPerlProc** ppProc); + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc); CPerlHost(const CPerlHost& host); virtual ~CPerlHost(void); @@ -73,21 +73,21 @@ public: inline void* Malloc(size_t size) { return m_pVMem->Malloc(size); }; inline void* Realloc(void* ptr, size_t size) { return m_pVMem->Realloc(ptr, size); }; inline void Free(void* ptr) { m_pVMem->Free(ptr); }; - inline void* Calloc(size_t num, size_t size){ return m_pVMem->Calloc(num, size); }; + inline void* Calloc(size_t num, size_t size){ return m_pVMem->Calloc(num, size); }; /* IPerlMemShared */ inline void* MallocShared(size_t size) { - return m_pVMemShared->Malloc(size); + return m_pVMemShared->Malloc(size); }; inline void* ReallocShared(void* ptr, size_t size) { return m_pVMemShared->Realloc(ptr, size); }; inline void FreeShared(void* ptr) { m_pVMemShared->Free(ptr); }; inline void* CallocShared(size_t num, size_t size) { - size_t count = num*size; - void* lpVoid = MallocShared(count); + size_t count = num*size; + void* lpVoid = MallocShared(count); - return lpVoid; + return lpVoid; }; /* IPerlMemParse */ @@ -96,10 +96,10 @@ public: inline void FreeParse(void* ptr) { m_pVMemParse->Free(ptr); }; inline void* CallocParse(size_t num, size_t size) { - size_t count = num*size; - void* lpVoid = MallocParse(count); + size_t count = num*size; + void* lpVoid = MallocParse(count); - return lpVoid; + return lpVoid; }; /* IPerlEnv */ @@ -107,11 +107,11 @@ public: int Putenv(const char *envstring); inline char *Getenv(const char *varname, unsigned long *len) { - *len = 0; - char *e = Getenv(varname); - if (e) - *len = strlen(e); - return e; + *len = 0; + char *e = Getenv(varname); + if (e) + *len = strlen(e); + return e; } @@ -341,33 +341,33 @@ PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name) void PerlEnvClearenv(struct IPerlEnv* piPerl) { - // If removed, compilation fails while compiling CGI2Perl. + // If removed, compilation fails while compiling CGI2Perl. } void* PerlEnvGetChildenv(struct IPerlEnv* piPerl) { - // If removed, compilation fails while compiling CGI2Perl. - return NULL; + // If removed, compilation fails while compiling CGI2Perl. + return NULL; } void PerlEnvFreeChildenv(struct IPerlEnv* piPerl, void* childEnv) { - // If removed, compilation fails while compiling CGI2Perl. + // If removed, compilation fails while compiling CGI2Perl. } char* PerlEnvGetChilddir(struct IPerlEnv* piPerl) { - // If removed, compilation fails while compiling CGI2Perl. - return NULL; + // If removed, compilation fails while compiling CGI2Perl. + return NULL; } void PerlEnvFreeChilddir(struct IPerlEnv* piPerl, char* childDir) { - // If removed, compilation fails while compiling CGI2Perl. + // If removed, compilation fails while compiling CGI2Perl. } struct IPerlEnv perlEnv = @@ -636,7 +636,7 @@ PerlStdIOSetpos(struct IPerlStdIO* piPerl, PerlIO* pf, const Fpos_t *p) void PerlStdIOInit(struct IPerlStdIO* piPerl) { - // If removed, compilation error occurs. + // If removed, compilation error occurs. } void @@ -668,17 +668,17 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, PerlIO* pf) /* open the file in the same mode */ if(((FILE*)pf)->_flag & _IOREAD) { - mode[0] = 'r'; - mode[1] = 0; + mode[0] = 'r'; + mode[1] = 0; } else if(((FILE*)pf)->_flag & _IOWRT) { - mode[0] = 'a'; - mode[1] = 0; + mode[0] = 'a'; + mode[1] = 0; } else if(((FILE*)pf)->_flag & _IORW) { - mode[0] = 'r'; - mode[1] = '+'; - mode[2] = 0; + mode[0] = 'r'; + mode[1] = '+'; + mode[2] = 0; } /* it appears that the binmode is attached to the @@ -689,7 +689,7 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, PerlIO* pf) /* move the file pointer to the same position */ if (!fgetpos((FILE*)pf, &pos)) { - fsetpos((FILE*)pfdup, &pos); + fsetpos((FILE*)pfdup, &pos); } return pfdup; } @@ -757,14 +757,14 @@ PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode) int PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int PerlLIOChsize(struct IPerlLIO* piPerl, int handle, long size) { - return (nw_chsize(handle,size)); + return (nw_chsize(handle,size)); } int @@ -788,7 +788,7 @@ PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2) int PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper) { - //On NetWare simulate flock by locking a range on the file + //On NetWare simulate flock by locking a range on the file return nw_flock(fd, oper); } @@ -801,8 +801,8 @@ PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer) int PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int @@ -832,7 +832,7 @@ PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer) char* PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template) { - return(nw_mktemp(Template)); + return(nw_mktemp(Template)); } int @@ -939,37 +939,37 @@ struct IPerlLIO perlLIO = int PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode) { - return mkdir(dirname); + return mkdir(dirname); } int PerlDirChdir(struct IPerlDir* piPerl, const char *dirname) { - return nw_chdir(dirname); + return nw_chdir(dirname); } int PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname) { - return nw_rmdir(dirname); + return nw_rmdir(dirname); } int PerlDirClose(struct IPerlDir* piPerl, DIR *dirp) { - return nw_closedir(dirp); + return nw_closedir(dirp); } DIR* PerlDirOpen(struct IPerlDir* piPerl, const char *filename) { - return nw_opendir(filename); + return nw_opendir(filename); } struct direct * PerlDirRead(struct IPerlDir* piPerl, DIR *dirp) { - return nw_readdir(dirp); + return nw_readdir(dirp); } void @@ -1008,42 +1008,42 @@ struct IPerlDir perlDir = u_long PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong) { - return(nw_htonl(hostlong)); + return(nw_htonl(hostlong)); } u_short PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort) { - return(nw_htons(hostshort)); + return(nw_htons(hostshort)); } u_long PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong) { - return nw_ntohl(netlong); + return nw_ntohl(netlong); } u_short PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort) { - return nw_ntohs(netshort); + return nw_ntohs(netshort); } SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen) { - return nw_accept(s, addr, addrlen); + return nw_accept(s, addr, addrlen); } int PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) { - return nw_bind(s, name, namelen); + return nw_bind(s, name, namelen); } int PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) { - return nw_connect(s, name, namelen); + return nw_connect(s, name, namelen); } void @@ -1073,7 +1073,7 @@ PerlSockEndservent(struct IPerlSock* piPerl) struct hostent* PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type) { - return(nw_gethostbyaddr(addr,len,type)); + return(nw_gethostbyaddr(addr,len,type)); } struct hostent* @@ -1085,13 +1085,13 @@ PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name) struct hostent* PerlSockGethostent(struct IPerlSock* piPerl) { - return(nw_gethostent()); + return(nw_gethostent()); } int PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen) { - return nw_gethostname(name,namelen); + return nw_gethostname(name,namelen); } struct netent * @@ -1144,31 +1144,31 @@ PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* pr struct servent* PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto) { - return nw_getservbyport(port, proto); + return nw_getservbyport(port, proto); } struct servent* PerlSockGetservent(struct IPerlSock* piPerl) { - return nw_getservent(); + return nw_getservent(); } int PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen) { - return nw_getsockname(s, name, namelen); + return nw_getsockname(s, name, namelen); } int PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen) { - return nw_getsockopt(s, level, optname, optval, optlen); + return nw_getsockopt(s, level, optname, optval, optlen); } unsigned long PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp) { - return(nw_inet_addr(cp)); + return(nw_inet_addr(cp)); } char* @@ -1180,79 +1180,79 @@ PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in) int PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog) { - return (nw_listen(s, backlog)); + return (nw_listen(s, backlog)); } int PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags) { - return (nw_recv(s, buffer, len, flags)); + return (nw_recv(s, buffer, len, flags)); } int PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen) { - return nw_recvfrom(s, buffer, len, flags, from, fromlen); + return nw_recvfrom(s, buffer, len, flags, from, fromlen); } int PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout) { - return nw_select(nfds, (fd_set*) readfds, (fd_set*) writefds, (fd_set*) exceptfds, timeout); + return nw_select(nfds, (fd_set*) readfds, (fd_set*) writefds, (fd_set*) exceptfds, timeout); } int PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags) { - return (nw_send(s, buffer, len, flags)); + return (nw_send(s, buffer, len, flags)); } int PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen) { - return(nw_sendto(s, buffer, len, flags, to, tolen)); + return(nw_sendto(s, buffer, len, flags, to, tolen)); } void PerlSockSethostent(struct IPerlSock* piPerl, int stayopen) { - nw_sethostent(stayopen); + nw_sethostent(stayopen); } void PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen) { - nw_setnetent(stayopen); + nw_setnetent(stayopen); } void PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen) { - nw_setprotoent(stayopen); + nw_setprotoent(stayopen); } void PerlSockSetservent(struct IPerlSock* piPerl, int stayopen) { - nw_setservent(stayopen); + nw_setservent(stayopen); } int PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen) { - return nw_setsockopt(s, level, optname, optval, optlen); + return nw_setsockopt(s, level, optname, optval, optlen); } int PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how) { - return nw_shutdown(s, how); + return nw_shutdown(s, how); } SOCKET PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol) { - return nw_socket(af, type, protocol); + return nw_socket(af, type, protocol); } int @@ -1266,9 +1266,9 @@ PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp) { - dTHX; // (J) dTHXo + dTHX; // (J) dTHXo Perl_croak(aTHX_ "ioctlsocket not implemented!\n"); - return 0; + return 0; } struct IPerlSock perlSock = @@ -1301,8 +1301,8 @@ struct IPerlSock perlSock = PerlSockGetsockname, PerlSockGetsockopt, PerlSockInetAddr, - PerlSockInetNtoa, - PerlSockListen, + PerlSockInetNtoa, + PerlSockListen, PerlSockRecv, PerlSockRecvfrom, PerlSockSelect, @@ -1314,9 +1314,9 @@ struct IPerlSock perlSock = PerlSockSetservent, PerlSockSetsockopt, PerlSockShutdown, - PerlSockSocket, + PerlSockSocket, PerlSockSocketpair, - //Following commented by sgp bcos of comiplation error too many initializers (E279) + //Following commented by sgp bcos of comiplation error too many initializers (E279) // PerlSockClosesocket, }; @@ -1342,25 +1342,25 @@ void PerlProcExit(struct IPerlProc* piPerl, int status) { // exit(status); - dTHX; - //dJMPENV; - JMPENV_JUMP(2); + dTHX; + //dJMPENV; + JMPENV_JUMP(2); } void PerlProc_Exit(struct IPerlProc* piPerl, int status) { // _exit(status); - dTHX; - //dJMPENV; - JMPENV_JUMP(2); + dTHX; + //dJMPENV; + JMPENV_JUMP(2); } int PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int @@ -1378,36 +1378,36 @@ PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const uid_t PerlProcGetuid(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } uid_t PerlProcGeteuid(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } gid_t PerlProcGetgid(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } gid_t PerlProcGetegid(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } char * PerlProcGetlogin(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return NULL; + // If removed, compilation error occurs. + return NULL; } int @@ -1436,7 +1436,7 @@ PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode) dTHX; // (J) dTHXo PERL_FLUSHALL_FOR_CHILD; - return (PerlIO*)nw_Popen((char *)command, (char *)mode, (int *)errno); + return (PerlIO*)nw_Popen((char *)command, (char *)mode, (int *)errno); } int @@ -1454,15 +1454,15 @@ PerlProcPipe(struct IPerlProc* piPerl, int *phandles) int PerlProcSetuid(struct IPerlProc* piPerl, uid_t u) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int PerlProcSetgid(struct IPerlProc* piPerl, gid_t g) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int @@ -1492,15 +1492,15 @@ PerlProcWaitpid(struct IPerlProc* piPerl, int pid, int *status, int flags) Sighandler_t PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode) { - // If removed, compilation error occurs. + // If removed, compilation error occurs. return 0; } int PerlProcFork(struct IPerlProc* piPerl) { - // If removed, compilation error occurs. - return 0; + // If removed, compilation error occurs. + return 0; } int @@ -1582,8 +1582,8 @@ CPerlHost::CPerlHost(void) m_pVMemShared = new VMem(); m_pVMemParse = new VMem(); - memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); - memcpy(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); + memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); + memcpy(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); memcpy(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); memcpy(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); memcpy(&m_hostperlStdIO, &perlStdIO, sizeof(perlStdIO)); @@ -1605,26 +1605,26 @@ CPerlHost::CPerlHost(void) #define SETUPEXCHANGE(xptr, iptr, table) \ STMT_START { \ - if (xptr) { \ - iptr = *xptr; \ - *xptr = &table; \ - } \ - else { \ - iptr = &table; \ - } \ + if (xptr) { \ + iptr = *xptr; \ + *xptr = &table; \ + } \ + else { \ + iptr = &table; \ + } \ } STMT_END CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, - struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, - struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, - struct IPerlDir** ppDir, struct IPerlSock** ppSock, - struct IPerlProc** ppProc) + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc) { m_pVMem = new VMem(); m_pVMemShared = new VMem(); m_pVMemParse = new VMem(); - memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); + memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); memcpy(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); memcpy(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); memcpy(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); @@ -1648,7 +1648,7 @@ CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, CPerlHost::CPerlHost(const CPerlHost& host) { - memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); + memcpy(&m_hostperlMem, &perlMem, sizeof(perlMem)); memcpy(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared)); memcpy(&m_hostperlMemParse, &perlMemParse, sizeof(perlMemParse)); memcpy(&m_hostperlEnv, &perlEnv, sizeof(perlEnv)); @@ -1672,26 +1672,26 @@ CPerlHost::CPerlHost(const CPerlHost& host) CPerlHost::~CPerlHost(void) { - if ( m_pVMemParse ) delete m_pVMemParse; - if ( m_pVMemShared ) delete m_pVMemShared; - if ( m_pVMem ) delete m_pVMem; + if ( m_pVMemParse ) delete m_pVMemParse; + if ( m_pVMemShared ) delete m_pVMemShared; + if ( m_pVMem ) delete m_pVMem; } char* CPerlHost::Getenv(const char *varname) { - // getenv is always present. In old CLIB, it is implemented - // to always return NULL. With java loaded on NW411, it will - // return values set by envset. Is correctly implemented by - // CLIB on MOAB. - // - return getenv(varname); + // getenv is always present. In old CLIB, it is implemented + // to always return NULL. With java loaded on NW411, it will + // return values set by envset. Is correctly implemented by + // CLIB on MOAB. + // + return getenv(varname); } int CPerlHost::Putenv(const char *envstring) { - return(putenv(envstring)); + return(putenv(envstring)); } diff --git a/NetWare/nwperlsys.c b/NetWare/nwperlsys.c index 32c15cb438..adc9abc75e 100644 --- a/NetWare/nwperlsys.c +++ b/NetWare/nwperlsys.c @@ -34,10 +34,10 @@ Function : fnFreeMemEntry Description : Called for each outstanding memory allocation at the end of a script run. - Frees the outstanding allocations + Frees the outstanding allocations Parameters : ptr (IN). - context (IN) + context (IN) Returns : Nothing. @@ -45,10 +45,10 @@ void fnFreeMemEntry(void* ptr, void* context) { - if(ptr) - { - PerlMemFree(NULL, ptr); - } + if(ptr) + { + PerlMemFree(NULL, ptr); + } } /*============================================================================================ @@ -84,21 +84,21 @@ perl_alloc(void) { PerlInterpreter* my_perl = NULL; - WCValHashTable<void*>* m_allocList; - m_allocList = new WCValHashTable<void*> (fnAllocListHash, 256); - fnInsertHashListAddrs(m_allocList, FALSE); - my_perl = perl_alloc_using(&perlMem, - &perlMem, - NULL, - &perlEnv, - &perlStdIO, - &perlLIO, - &perlDir, - &perlSock, - &perlProc); - if (my_perl) { - //nw5_internal_host = m_allocList; - } + WCValHashTable<void*>* m_allocList; + m_allocList = new WCValHashTable<void*> (fnAllocListHash, 256); + fnInsertHashListAddrs(m_allocList, FALSE); + my_perl = perl_alloc_using(&perlMem, + &perlMem, + NULL, + &perlEnv, + &perlStdIO, + &perlLIO, + &perlDir, + &perlSock, + &perlProc); + if (my_perl) { + //nw5_internal_host = m_allocList; + } return my_perl; } @@ -115,72 +115,72 @@ perl_alloc(void) ==============================================================================================*/ EXTERN_C PerlInterpreter* perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, - struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, - struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, - struct IPerlDir** ppDir, struct IPerlSock** ppSock, - struct IPerlProc** ppProc) + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc) { PerlInterpreter *my_perl = NULL; - struct IPerlMem* lpMem; - struct IPerlEnv* lpEnv; - struct IPerlStdIO* lpStdio; - struct IPerlLIO* lpLIO; - struct IPerlDir* lpDir; - struct IPerlSock* lpSock; - struct IPerlProc* lpProc; - - WCValHashTable<void*>* m_allocList; - m_allocList = new WCValHashTable<void*> (fnAllocListHash, 256); - fnInsertHashListAddrs(m_allocList, FALSE); - - if (!ppMem) - lpMem=&perlMem; - else - lpMem=*ppMem; - - if (!ppEnv) - lpEnv=&perlEnv; - else - lpEnv=*ppEnv; - - if (!ppStdIO) - lpStdio=&perlStdIO; - else - lpStdio=*ppStdIO; - - if (!ppLIO) - lpLIO=&perlLIO; - else - lpLIO=*ppLIO; - - if (!ppDir) - lpDir=&perlDir; - else - lpDir=*ppDir; - - if (!ppSock) - lpSock=&perlSock; - else - lpSock=*ppSock; - - if (!ppProc) - lpProc=&perlProc; - else - lpProc=*ppProc; - my_perl = perl_alloc_using(lpMem, - lpMem, - NULL, - lpEnv, - lpStdio, - lpLIO, - lpDir, - lpSock, - lpProc); - - if (my_perl) { - //nw5_internal_host = pHost; - } + struct IPerlMem* lpMem; + struct IPerlEnv* lpEnv; + struct IPerlStdIO* lpStdio; + struct IPerlLIO* lpLIO; + struct IPerlDir* lpDir; + struct IPerlSock* lpSock; + struct IPerlProc* lpProc; + + WCValHashTable<void*>* m_allocList; + m_allocList = new WCValHashTable<void*> (fnAllocListHash, 256); + fnInsertHashListAddrs(m_allocList, FALSE); + + if (!ppMem) + lpMem=&perlMem; + else + lpMem=*ppMem; + + if (!ppEnv) + lpEnv=&perlEnv; + else + lpEnv=*ppEnv; + + if (!ppStdIO) + lpStdio=&perlStdIO; + else + lpStdio=*ppStdIO; + + if (!ppLIO) + lpLIO=&perlLIO; + else + lpLIO=*ppLIO; + + if (!ppDir) + lpDir=&perlDir; + else + lpDir=*ppDir; + + if (!ppSock) + lpSock=&perlSock; + else + lpSock=*ppSock; + + if (!ppProc) + lpProc=&perlProc; + else + lpProc=*ppProc; + my_perl = perl_alloc_using(lpMem, + lpMem, + NULL, + lpEnv, + lpStdio, + lpLIO, + lpDir, + lpSock, + lpProc); + + if (my_perl) { + //nw5_internal_host = pHost; + } return my_perl; } /*============================================================================================ @@ -198,19 +198,19 @@ perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, EXTERN_C void nw5_delete_internal_host(void *h) { - WCValHashTable<void*>* m_allocList; - void **listptr; - BOOL m_dontTouchHashLists; - if (fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { - m_allocList = (WCValHashTable<void*>*)listptr; - fnInsertHashListAddrs(m_allocList, TRUE); - if (m_allocList) - { - m_allocList->forAll(fnFreeMemEntry, NULL); - fnInsertHashListAddrs(NULL, FALSE); - delete m_allocList; - } - } + WCValHashTable<void*>* m_allocList; + void **listptr; + BOOL m_dontTouchHashLists; + if (fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { + m_allocList = (WCValHashTable<void*>*)listptr; + fnInsertHashListAddrs(m_allocList, TRUE); + if (m_allocList) + { + m_allocList->forAll(fnFreeMemEntry, NULL); + fnInsertHashListAddrs(NULL, FALSE); + delete m_allocList; + } + } } #endif /* PERL_IMPLICIT_SYS */ diff --git a/NetWare/nwperlsys.h b/NetWare/nwperlsys.h index 3d82dd1c8d..34f713d287 100644 --- a/NetWare/nwperlsys.h +++ b/NetWare/nwperlsys.h @@ -48,103 +48,103 @@ END_EXTERN_C void* PerlMemMalloc(struct IPerlMem* piPerl, size_t size) { - void *ptr = NULL; - ptr = malloc(size); - if (ptr) { - void **listptr; - BOOL m_dontTouchHashLists; - if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { - if (listptr) { - WCValHashTable<void*>* m_allocList= (WCValHashTable<void*>*)listptr; - (WCValHashTable<void*>*)m_allocList->insert(ptr); - } - } - } - return(ptr); + void *ptr = NULL; + ptr = malloc(size); + if (ptr) { + void **listptr; + BOOL m_dontTouchHashLists; + if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { + if (listptr) { + WCValHashTable<void*>* m_allocList= (WCValHashTable<void*>*)listptr; + (WCValHashTable<void*>*)m_allocList->insert(ptr); + } + } + } + return(ptr); } void* PerlMemRealloc(struct IPerlMem* piPerl, void* ptr, size_t size) { - void *newptr = NULL; - WCValHashTable<void*>* m_allocList; + void *newptr = NULL; + WCValHashTable<void*>* m_allocList; - newptr = realloc(ptr, size); + newptr = realloc(ptr, size); - if (ptr) - { - void **listptr; - BOOL m_dontTouchHashLists; - if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { - m_allocList= (WCValHashTable<void*>*)listptr; - (WCValHashTable<void*>*)m_allocList->remove(ptr); - } - } - if (newptr) - { - if (m_allocList) - (WCValHashTable<void*>*)m_allocList->insert(newptr); - } + if (ptr) + { + void **listptr; + BOOL m_dontTouchHashLists; + if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { + m_allocList= (WCValHashTable<void*>*)listptr; + (WCValHashTable<void*>*)m_allocList->remove(ptr); + } + } + if (newptr) + { + if (m_allocList) + (WCValHashTable<void*>*)m_allocList->insert(newptr); + } - return(newptr); + return(newptr); } void PerlMemFree(struct IPerlMem* piPerl, void* ptr) { - BOOL m_dontTouchHashLists; - WCValHashTable<void*>* m_allocList; - - void **listptr; - if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { - m_allocList= (WCValHashTable<void*>*)listptr; - // Final clean up, free all the nodes from the hash list - if (m_dontTouchHashLists) - { - if(ptr) - { - free(ptr); - ptr = NULL; - } - } - else - { - if(ptr && m_allocList) - { - if ((WCValHashTable<void*>*)m_allocList->remove(ptr)) - { - free(ptr); - ptr = NULL; - } - else - { - // If it comes here, that means that the memory pointer is not contained in the hash list. - // But no need to free now, since if is deleted here, it will result in an abend!! - // If the memory is still there, it will be cleaned during final cleanup anyway. - } - } - } - } - return; + BOOL m_dontTouchHashLists; + WCValHashTable<void*>* m_allocList; + + void **listptr; + if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { + m_allocList= (WCValHashTable<void*>*)listptr; + // Final clean up, free all the nodes from the hash list + if (m_dontTouchHashLists) + { + if(ptr) + { + free(ptr); + ptr = NULL; + } + } + else + { + if(ptr && m_allocList) + { + if ((WCValHashTable<void*>*)m_allocList->remove(ptr)) + { + free(ptr); + ptr = NULL; + } + else + { + // If it comes here, that means that the memory pointer is not contained in the hash list. + // But no need to free now, since if is deleted here, it will result in an abend!! + // If the memory is still there, it will be cleaned during final cleanup anyway. + } + } + } + } + return; } void* PerlMemCalloc(struct IPerlMem* piPerl, size_t num, size_t size) { - void *ptr = NULL; + void *ptr = NULL; - ptr = calloc(num, size); - if (ptr) { - void **listptr; - BOOL m_dontTouchHashLists; - if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { - if (listptr) { - WCValHashTable<void*>* m_allocList= (WCValHashTable<void*>*)listptr; - (WCValHashTable<void*>*)m_allocList->insert(ptr); - } - } - } - return(ptr); + ptr = calloc(num, size); + if (ptr) { + void **listptr; + BOOL m_dontTouchHashLists; + if(fnGetHashListAddrs(&listptr,&m_dontTouchHashLists)) { + if (listptr) { + WCValHashTable<void*>* m_allocList= (WCValHashTable<void*>*)listptr; + (WCValHashTable<void*>*)m_allocList->insert(ptr); + } + } + } + return(ptr); } struct IPerlMem perlMem = @@ -162,37 +162,37 @@ struct IPerlMem perlMem = int PerlDirMakedir(struct IPerlDir* piPerl, const char *dirname, int mode) { - return mkdir(dirname); + return mkdir(dirname); } int PerlDirChdir(struct IPerlDir* piPerl, const char *dirname) { - return nw_chdir(dirname); + return nw_chdir(dirname); } int PerlDirRmdir(struct IPerlDir* piPerl, const char *dirname) { - return nw_rmdir(dirname); + return nw_rmdir(dirname); } int PerlDirClose(struct IPerlDir* piPerl, DIR *dirp) { - return nw_closedir(dirp); + return nw_closedir(dirp); } DIR* PerlDirOpen(struct IPerlDir* piPerl, const char *filename) { - return nw_opendir(filename); + return nw_opendir(filename); } struct direct * PerlDirRead(struct IPerlDir* piPerl, DIR *dirp) { - return nw_readdir(dirp); + return nw_readdir(dirp); } void @@ -215,7 +215,7 @@ PerlDirTell(struct IPerlDir* piPerl, DIR *dirp) struct IPerlDir perlDir = { - PerlDirMakedir, + PerlDirMakedir, PerlDirChdir, PerlDirRmdir, PerlDirClose, @@ -233,23 +233,23 @@ struct IPerlDir perlDir = char* PerlEnvGetenv(struct IPerlEnv* piPerl, const char *varname) { - return(getenv(varname)); + return(getenv(varname)); }; int PerlEnvPutenv(struct IPerlEnv* piPerl, const char *envstring) { - return(putenv(envstring)); + return(putenv(envstring)); }; char* PerlEnvGetenv_len(struct IPerlEnv* piPerl, const char* varname, unsigned long* len) { - *len = 0; - char *e = getenv(varname); - if (e) - *len = strlen(e); - return e; + *len = 0; + char *e = getenv(varname); + if (e) + *len = strlen(e); + return e; } int @@ -261,13 +261,13 @@ PerlEnvUname(struct IPerlEnv* piPerl, struct utsname *name) void PerlEnvClearenv(struct IPerlEnv* piPerl) { - + } struct IPerlEnv perlEnv = { - PerlEnvGetenv, - PerlEnvPutenv, + PerlEnvGetenv, + PerlEnvPutenv, PerlEnvGetenv_len, PerlEnvUname, PerlEnvClearenv, @@ -559,17 +559,17 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf) /* open the file in the same mode */ if(((FILE*)pf)->_flag & _IOREAD) { - mode[0] = 'r'; - mode[1] = 0; + mode[0] = 'r'; + mode[1] = 0; } else if(((FILE*)pf)->_flag & _IOWRT) { - mode[0] = 'a'; - mode[1] = 0; + mode[0] = 'a'; + mode[1] = 0; } else if(((FILE*)pf)->_flag & _IORW) { - mode[0] = 'r'; - mode[1] = '+'; - mode[2] = 0; + mode[0] = 'r'; + mode[1] = '+'; + mode[2] = 0; } /* it appears that the binmode is attached to the @@ -580,14 +580,14 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf) /* move the file pointer to the same position */ if (!fgetpos(pf, &pos)) { - fsetpos(pfdup, &pos); + fsetpos(pfdup, &pos); } return pfdup; } struct IPerlStdIO perlStdIO = { - PerlStdIOStdin, + PerlStdIOStdin, PerlStdIOStdout, PerlStdIOStderr, PerlStdIOOpen, @@ -647,15 +647,15 @@ PerlLIOChmod(struct IPerlLIO* piPerl, const char *filename, int pmode) int PerlLIOChown(struct IPerlLIO* piPerl, const char *filename, uid_t owner, gid_t group) { - dTHX; + dTHX; Perl_croak(aTHX_ "chown not implemented!\n"); - return 0; + return 0; } int PerlLIOChsize(struct IPerlLIO* piPerl, int handle, long size) { - return (nw_chsize(handle,size)); + return (nw_chsize(handle,size)); } int @@ -679,7 +679,7 @@ PerlLIODup2(struct IPerlLIO* piPerl, int handle1, int handle2) int PerlLIOFlock(struct IPerlLIO* piPerl, int fd, int oper) { - //On NetWare simulate flock by locking a range on the file + //On NetWare simulate flock by locking a range on the file return nw_flock(fd, oper); } @@ -692,7 +692,7 @@ PerlLIOFileStat(struct IPerlLIO* piPerl, int handle, struct stat *buffer) int PerlLIOIOCtl(struct IPerlLIO* piPerl, int i, unsigned int u, char *data) { - return 0; + return 0; } int @@ -722,7 +722,7 @@ PerlLIOLstat(struct IPerlLIO* piPerl, const char *path, struct stat *buffer) char* PerlLIOMktemp(struct IPerlLIO* piPerl, char *Template) { - return(nw_mktemp(Template)); + return(nw_mktemp(Template)); } int @@ -793,7 +793,7 @@ PerlLIOWrite(struct IPerlLIO* piPerl, int handle, const void *buffer, unsigned i struct IPerlLIO perlLIO = { - PerlLIOAccess, + PerlLIOAccess, PerlLIOChmod, PerlLIOChown, PerlLIOChsize, @@ -844,26 +844,26 @@ void PerlProcExit(struct IPerlProc* piPerl, int status) { // exit(status); - dTHX; - dJMPENV; - JMPENV_JUMP(2); + dTHX; + dJMPENV; + JMPENV_JUMP(2); } void PerlProc_Exit(struct IPerlProc* piPerl, int status) { // _exit(status); - dTHX; - dJMPENV; - JMPENV_JUMP(2); + dTHX; + dJMPENV; + JMPENV_JUMP(2); } int PerlProcExecl(struct IPerlProc* piPerl, const char *cmdname, const char *arg0, const char *arg1, const char *arg2, const char *arg3) { - dTHX; + dTHX; Perl_croak(aTHX_ "execl not implemented!\n"); - return 0; + return 0; } int @@ -881,31 +881,31 @@ PerlProcExecvp(struct IPerlProc* piPerl, const char *cmdname, const char *const uid_t PerlProcGetuid(struct IPerlProc* piPerl) { - return 0; + return 0; } uid_t PerlProcGeteuid(struct IPerlProc* piPerl) { - return 0; + return 0; } gid_t PerlProcGetgid(struct IPerlProc* piPerl) { - return 0; + return 0; } gid_t PerlProcGetegid(struct IPerlProc* piPerl) { - return 0; + return 0; } char * PerlProcGetlogin(struct IPerlProc* piPerl) { - return NULL; + return NULL; } int @@ -934,7 +934,7 @@ PerlProcPopen(struct IPerlProc* piPerl, const char *command, const char *mode) dTHX; PERL_FLUSHALL_FOR_CHILD; - return (PerlIO*)nw_Popen((char *)command, (char *)mode, (int *)errno); + return (PerlIO*)nw_Popen((char *)command, (char *)mode, (int *)errno); } int @@ -952,13 +952,13 @@ PerlProcPipe(struct IPerlProc* piPerl, int *phandles) int PerlProcSetuid(struct IPerlProc* piPerl, uid_t u) { - return 0; + return 0; } int PerlProcSetgid(struct IPerlProc* piPerl, gid_t g) { - return 0; + return 0; } int @@ -994,7 +994,7 @@ PerlProcSignal(struct IPerlProc* piPerl, int sig, Sighandler_t subcode) int PerlProcFork(struct IPerlProc* piPerl) { - return 0; + return 0; } int @@ -1068,42 +1068,42 @@ struct IPerlProc perlProc = u_long PerlSockHtonl(struct IPerlSock* piPerl, u_long hostlong) { - return(nw_htonl(hostlong)); + return(nw_htonl(hostlong)); } u_short PerlSockHtons(struct IPerlSock* piPerl, u_short hostshort) { - return(nw_htons(hostshort)); + return(nw_htons(hostshort)); } u_long PerlSockNtohl(struct IPerlSock* piPerl, u_long netlong) { - return nw_ntohl(netlong); + return nw_ntohl(netlong); } u_short PerlSockNtohs(struct IPerlSock* piPerl, u_short netshort) { - return nw_ntohs(netshort); + return nw_ntohs(netshort); } SOCKET PerlSockAccept(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* addr, int* addrlen) { - return nw_accept(s, addr, addrlen); + return nw_accept(s, addr, addrlen); } int PerlSockBind(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) { - return nw_bind(s, name, namelen); + return nw_bind(s, name, namelen); } int PerlSockConnect(struct IPerlSock* piPerl, SOCKET s, const struct sockaddr* name, int namelen) { - return nw_connect(s, name, namelen); + return nw_connect(s, name, namelen); } void @@ -1133,7 +1133,7 @@ PerlSockEndservent(struct IPerlSock* piPerl) struct hostent* PerlSockGethostbyaddr(struct IPerlSock* piPerl, const char* addr, int len, int type) { - return(nw_gethostbyaddr(addr,len,type)); + return(nw_gethostbyaddr(addr,len,type)); } struct hostent* @@ -1145,13 +1145,13 @@ PerlSockGethostbyname(struct IPerlSock* piPerl, const char* name) struct hostent* PerlSockGethostent(struct IPerlSock* piPerl) { - return(nw_gethostent()); + return(nw_gethostent()); } int PerlSockGethostname(struct IPerlSock* piPerl, char* name, int namelen) { - return nw_gethostname(name,namelen); + return nw_gethostname(name,namelen); } struct netent * @@ -1204,115 +1204,115 @@ PerlSockGetservbyname(struct IPerlSock* piPerl, const char* name, const char* pr struct servent* PerlSockGetservbyport(struct IPerlSock* piPerl, int port, const char* proto) { - return nw_getservbyport(port, proto); + return nw_getservbyport(port, proto); } struct servent* PerlSockGetservent(struct IPerlSock* piPerl) { - return nw_getservent(); + return nw_getservent(); } int PerlSockGetsockname(struct IPerlSock* piPerl, SOCKET s, struct sockaddr* name, int* namelen) { - return nw_getsockname(s, name, namelen); + return nw_getsockname(s, name, namelen); } int PerlSockGetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, char* optval, int* optlen) { - return nw_getsockopt(s, level, optname, optval, optlen); + return nw_getsockopt(s, level, optname, optval, optlen); } unsigned long PerlSockInetAddr(struct IPerlSock* piPerl, const char* cp) { - return(nw_inet_addr(cp)); + return(nw_inet_addr(cp)); } char* PerlSockInetNtoa(struct IPerlSock* piPerl, struct in_addr in) { - return NULL; + return NULL; } int PerlSockListen(struct IPerlSock* piPerl, SOCKET s, int backlog) { - return (nw_listen(s, backlog)); + return (nw_listen(s, backlog)); } int PerlSockRecv(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags) { - return (nw_recv(s, buffer, len, flags)); + return (nw_recv(s, buffer, len, flags)); } int PerlSockRecvfrom(struct IPerlSock* piPerl, SOCKET s, char* buffer, int len, int flags, struct sockaddr* from, int* fromlen) { - return nw_recvfrom(s, buffer, len, flags, from, fromlen); + return nw_recvfrom(s, buffer, len, flags, from, fromlen); } int PerlSockSelect(struct IPerlSock* piPerl, int nfds, char* readfds, char* writefds, char* exceptfds, const struct timeval* timeout) { - return nw_select(nfds, (fd_set*) readfds, (fd_set*) writefds, (fd_set*) exceptfds, timeout); + return nw_select(nfds, (fd_set*) readfds, (fd_set*) writefds, (fd_set*) exceptfds, timeout); } int PerlSockSend(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags) { - return (nw_send(s, buffer, len, flags)); + return (nw_send(s, buffer, len, flags)); } int PerlSockSendto(struct IPerlSock* piPerl, SOCKET s, const char* buffer, int len, int flags, const struct sockaddr* to, int tolen) { - return(nw_sendto(s, buffer, len, flags, to, tolen)); + return(nw_sendto(s, buffer, len, flags, to, tolen)); } void PerlSockSethostent(struct IPerlSock* piPerl, int stayopen) { - nw_sethostent(stayopen); + nw_sethostent(stayopen); } void PerlSockSetnetent(struct IPerlSock* piPerl, int stayopen) { - nw_setnetent(stayopen); + nw_setnetent(stayopen); } void PerlSockSetprotoent(struct IPerlSock* piPerl, int stayopen) { - nw_setprotoent(stayopen); + nw_setprotoent(stayopen); } void PerlSockSetservent(struct IPerlSock* piPerl, int stayopen) { - nw_setservent(stayopen); + nw_setservent(stayopen); } int PerlSockSetsockopt(struct IPerlSock* piPerl, SOCKET s, int level, int optname, const char* optval, int optlen) { - return nw_setsockopt(s, level, optname, optval, optlen); + return nw_setsockopt(s, level, optname, optval, optlen); } int PerlSockShutdown(struct IPerlSock* piPerl, SOCKET s, int how) { - return nw_shutdown(s, how); + return nw_shutdown(s, how); } SOCKET PerlSockSocket(struct IPerlSock* piPerl, int af, int type, int protocol) { - return nw_socket(af, type, protocol); + return nw_socket(af, type, protocol); } int @@ -1326,14 +1326,14 @@ PerlSockSocketpair(struct IPerlSock* piPerl, int domain, int type, int protocol, int PerlSockIoctlsocket(struct IPerlSock* piPerl, SOCKET s, long cmd, u_long *argp) { - dTHX; + dTHX; Perl_croak(aTHX_ "ioctlsocket not implemented!\n"); - return 0; + return 0; } struct IPerlSock perlSock = { - PerlSockHtonl, + PerlSockHtonl, PerlSockHtons, PerlSockNtohl, PerlSockNtohs, @@ -1361,8 +1361,8 @@ struct IPerlSock perlSock = PerlSockGetsockname, PerlSockGetsockopt, PerlSockInetAddr, - PerlSockInetNtoa, - PerlSockListen, + PerlSockInetNtoa, + PerlSockListen, PerlSockRecv, PerlSockRecvfrom, PerlSockSelect, @@ -1374,7 +1374,7 @@ struct IPerlSock perlSock = PerlSockSetservent, PerlSockSetsockopt, PerlSockShutdown, - PerlSockSocket, + PerlSockSocket, PerlSockSocketpair, }; diff --git a/NetWare/nwpipe.h b/NetWare/nwpipe.h index 462a73dcf4..1cf58706c1 100644 --- a/NetWare/nwpipe.h +++ b/NetWare/nwpipe.h @@ -29,24 +29,24 @@ typedef struct tagTempPipeFile { - BOOL m_mode; // FALSE - Read mode ; TRUE - Write mode - BOOL m_launchPerl; - BOOL m_doPerlGlob; + BOOL m_mode; // FALSE - Read mode ; TRUE - Write mode + BOOL m_launchPerl; + BOOL m_doPerlGlob; - int m_argv_len; + int m_argv_len; - char * m_fileName; - char** m_argv; - char * m_redirect; + char * m_fileName; + char** m_argv; + char * m_redirect; - #ifdef MPK_ON - SEMAPHORE m_perlSynchSemaphore; - #else - long m_perlSynchSemaphore; - #endif + #ifdef MPK_ON + SEMAPHORE m_perlSynchSemaphore; + #else + long m_perlSynchSemaphore; + #endif - FILE* m_file; - PCOMMANDLINEPARSER m_pipeCommand; + FILE* m_file; + PCOMMANDLINEPARSER m_pipeCommand; } TEMPPIPEFILE, *PTEMPPIPEFILE; diff --git a/NetWare/nwplglob.c b/NetWare/nwplglob.c index 6810fd5e69..fba55da7ab 100644 --- a/NetWare/nwplglob.c +++ b/NetWare/nwplglob.c @@ -36,7 +36,7 @@ Description : Perl globbing support: Takes an array of wildcard descriptors and produces from it a list of files that the wildcards expand into. - The list of files is written to the temporary file named by fileName. + The list of files is written to the temporary file named by fileName. Parameters : argv (IN) - Input argument vector. fileName (IN) - Input file name for storing globed file names. @@ -47,44 +47,44 @@ void fnDoPerlGlob(char** argv, char* fileName) { - FILE * redirOut = NULL; + FILE * redirOut = NULL; - if (*argv) - argv++; - if (*argv == NULL) - return; + if (*argv) + argv++; + if (*argv == NULL) + return; - redirOut = fopen((const char *)fileName, (const char *)"w"); - if (!redirOut) - return; + redirOut = fopen((const char *)fileName, (const char *)"w"); + if (!redirOut) + return; - do - { - DIR* dir = NULL; - DIR* fil = NULL; - char* pattern = NULL; + do + { + DIR* dir = NULL; + DIR* fil = NULL; + char* pattern = NULL; - pattern = *argv++; + pattern = *argv++; - dir = opendir((const char *)pattern); - if (!dir) - continue; + dir = opendir((const char *)pattern); + if (!dir) + continue; - /* find the last separator in pattern, NetWare has three: /\: */ - while (fil = readdir(dir)) - { - // The below displays the files separated by tab character. - // Also, it displays only the file names and not directories. - // If any other format is desired, it needs to be done here. - fprintf(redirOut, "%s\t", fil->d_name); - } + /* find the last separator in pattern, NetWare has three: /\: */ + while (fil = readdir(dir)) + { + // The below displays the files separated by tab character. + // Also, it displays only the file names and not directories. + // If any other format is desired, it needs to be done here. + fprintf(redirOut, "%s\t", fil->d_name); + } - closedir(dir); + closedir(dir); - } while (*argv); + } while (*argv); - fclose(redirOut); + fclose(redirOut); - return; + return; } diff --git a/NetWare/nwtinfo.h b/NetWare/nwtinfo.h index a08d060422..d8503d2811 100644 --- a/NetWare/nwtinfo.h +++ b/NetWare/nwtinfo.h @@ -25,10 +25,10 @@ typedef struct tagThreadInfo { - int tid; - struct tagThreadInfo *next; - BOOL m_dontTouchHashLists; - void* m_allocList; + int tid; + struct tagThreadInfo *next; + BOOL m_dontTouchHashLists; + void* m_allocList; }ThreadInfo; void fnInitializeThreadInfo(void); @@ -39,17 +39,17 @@ BOOL fnRemoveThreadInfo(int tid); ThreadInfo* fnGetThreadInfo(int tid); #ifdef __cplusplus - //For storing and retrieving Watcom Hash list address - extern "C" BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList); - //Registering with the Thread table - extern "C" BOOL fnRegisterWithThreadTable(void); - extern "C" BOOL fnUnregisterWithThreadTable(void); + //For storing and retrieving Watcom Hash list address + extern "C" BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList); + //Registering with the Thread table + extern "C" BOOL fnRegisterWithThreadTable(void); + extern "C" BOOL fnUnregisterWithThreadTable(void); #else - //For storing and retrieving Watcom Hash list address - BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList); - //Registering with the Thread table - BOOL fnRegisterWithThreadTable(void); - BOOL fnUnregisterWithThreadTable(void); + //For storing and retrieving Watcom Hash list address + BOOL fnInsertHashListAddrs(void *addrs, BOOL dontTouchHashList); + //Registering with the Thread table + BOOL fnRegisterWithThreadTable(void); + BOOL fnUnregisterWithThreadTable(void); #endif BOOL fnGetHashListAddrs(void **addrs, BOOL *dontTouchHashList); @@ -58,9 +58,9 @@ BOOL fnGetHashListAddrs(void **addrs, BOOL *dontTouchHashList); //or see if the above portion can be removed once this works properly typedef struct tagThreadCtx { - long tid; - void *tInfo; - struct tagThreadCtx *next; + long tid; + void *tInfo; + struct tagThreadCtx *next; }ThreadContext; diff --git a/NetWare/nwutil.h b/NetWare/nwutil.h index ff05d1830f..a27161147d 100644 --- a/NetWare/nwutil.h +++ b/NetWare/nwutil.h @@ -27,10 +27,10 @@ #ifdef MPK_ON - #include <mpktypes.h> - #include <mpkapis.h> + #include <mpktypes.h> + #include <mpkapis.h> #else - #include <nwsemaph.h> + #include <nwsemaph.h> #endif //MPK_ON @@ -43,28 +43,28 @@ typedef struct tagCommandLineParser { - BOOL m_noScreen; - BOOL m_AutoDestroy; - BOOL m_isValid; - - int m_argc; - int m_argv_len; - - #ifdef MPK_ON - SEMAPHORE m_qSemaphore; - #else - long m_qSemaphore; - #endif - - char* m_redirInName; - char* m_redirOutName; - char* m_redirErrName; - char* m_redirBothName; - char* nextarg; - char* sSkippedToken; - - char** m_argv; - char** new_argv; + BOOL m_noScreen; + BOOL m_AutoDestroy; + BOOL m_isValid; + + int m_argc; + int m_argv_len; + + #ifdef MPK_ON + SEMAPHORE m_qSemaphore; + #else + long m_qSemaphore; + #endif + + char* m_redirInName; + char* m_redirOutName; + char* m_redirErrName; + char* m_redirBothName; + char* nextarg; + char* sSkippedToken; + + char** m_argv; + char** new_argv; }COMMANDLINEPARSER, *PCOMMANDLINEPARSER; diff --git a/NetWare/nwvmem.h b/NetWare/nwvmem.h index e82eaeef8b..98b2873044 100644 --- a/NetWare/nwvmem.h +++ b/NetWare/nwvmem.h @@ -38,12 +38,12 @@ public: virtual void* Malloc(size_t size); virtual void* Realloc(void* pMem, size_t size); virtual void Free(void* pMem); - virtual void* Calloc(size_t num, size_t size); + virtual void* Calloc(size_t num, size_t size); protected: - BOOL m_dontTouchHashLists; + BOOL m_dontTouchHashLists; // WCValHashTable<void*>* m_allocList; - NWPerlHashList *m_allocList; // CW changes + NWPerlHashList *m_allocList; // CW changes }; @@ -73,10 +73,10 @@ unsigned fnAllocListHash(void* const& invalue) Function : fnFreeMemEntry Description : Called for each outstanding memory allocation at the end of a script run. - Frees the outstanding allocations + Frees the outstanding allocations Parameters : ptr (IN). - context (IN) + context (IN) Returns : Nothing. @@ -84,15 +84,15 @@ unsigned fnAllocListHash(void* const& invalue) void fnFreeMemEntry(void* ptr, void* context) { - VMem* pVMem = (VMem*) context; - - if(ptr && pVMem) - { - pVMem->Free(ptr); - ptr=NULL; - pVMem = NULL; - context = NULL; - } + VMem* pVMem = (VMem*) context; + + if(ptr && pVMem) + { + pVMem->Free(ptr); + ptr=NULL; + pVMem = NULL; + context = NULL; + } } @@ -111,11 +111,11 @@ void fnFreeMemEntry(void* ptr, void* context) VMem::VMem() { - //Constructor - m_dontTouchHashLists = FALSE; - m_allocList = NULL; - // m_allocList = new WCValHashTable<void*> (fnAllocListHash, 256); - m_allocList = new NWPerlHashList(); // CW changes + //Constructor + m_dontTouchHashLists = FALSE; + m_allocList = NULL; + // m_allocList = new WCValHashTable<void*> (fnAllocListHash, 256); + m_allocList = new NWPerlHashList(); // CW changes } @@ -134,16 +134,16 @@ VMem::VMem() VMem::~VMem(void) { - //Destructor - m_dontTouchHashLists = TRUE; - if (m_allocList) - { - m_allocList->forAll(fnFreeMemEntry, (void*) this); - - delete m_allocList; - m_allocList = NULL; - } - m_dontTouchHashLists = FALSE; + //Destructor + m_dontTouchHashLists = TRUE; + if (m_allocList) + { + m_allocList->forAll(fnFreeMemEntry, (void*) this); + + delete m_allocList; + m_allocList = NULL; + } + m_dontTouchHashLists = FALSE; } @@ -162,33 +162,33 @@ VMem::~VMem(void) void* VMem::Malloc(size_t size) { - void *ptr = NULL; - - if (size <= 0) - return NULL; - - ptr = malloc(size); - if (ptr) - { - if(m_allocList) - m_allocList->insert(ptr); - } - else - { - m_dontTouchHashLists = TRUE; - if (m_allocList) - { - m_allocList->forAll(fnFreeMemEntry, (void*) this); - delete m_allocList; - m_allocList = NULL; - } - m_dontTouchHashLists = FALSE; - - // Serious error since memory allocation falied. So, exiting... - ExitThread(TSR_THREAD, 1); - } - - return(ptr); + void *ptr = NULL; + + if (size <= 0) + return NULL; + + ptr = malloc(size); + if (ptr) + { + if(m_allocList) + m_allocList->insert(ptr); + } + else + { + m_dontTouchHashLists = TRUE; + if (m_allocList) + { + m_allocList->forAll(fnFreeMemEntry, (void*) this); + delete m_allocList; + m_allocList = NULL; + } + m_dontTouchHashLists = FALSE; + + // Serious error since memory allocation falied. So, exiting... + ExitThread(TSR_THREAD, 1); + } + + return(ptr); } @@ -200,7 +200,7 @@ void* VMem::Malloc(size_t size) Description : Reallocates block of memory. Parameters : block (IN) - Points to a previously allocated memory block. - size (IN) - Size of memory to be allocated. + size (IN) - Size of memory to be allocated. Returns : Pointer to the allocated memory block. @@ -208,38 +208,38 @@ void* VMem::Malloc(size_t size) void* VMem::Realloc(void* block, size_t size) { - void *ptr = NULL; - - if (size <= 0) - return NULL; - - ptr = realloc(block, size); - if (ptr) - { - if (block) - { - if (m_allocList) - m_allocList->remove(block); - } - if (m_allocList) - m_allocList->insert(ptr); - } - else - { - m_dontTouchHashLists = TRUE; - if (m_allocList) - { - m_allocList->forAll(fnFreeMemEntry, (void*) this); - delete m_allocList; - m_allocList = NULL; - } - m_dontTouchHashLists = FALSE; - - // Serious error since memory allocation falied. So, exiting... - ExitThread(TSR_THREAD, 1); - } - - return(ptr); + void *ptr = NULL; + + if (size <= 0) + return NULL; + + ptr = realloc(block, size); + if (ptr) + { + if (block) + { + if (m_allocList) + m_allocList->remove(block); + } + if (m_allocList) + m_allocList->insert(ptr); + } + else + { + m_dontTouchHashLists = TRUE; + if (m_allocList) + { + m_allocList->forAll(fnFreeMemEntry, (void*) this); + delete m_allocList; + m_allocList = NULL; + } + m_dontTouchHashLists = FALSE; + + // Serious error since memory allocation falied. So, exiting... + ExitThread(TSR_THREAD, 1); + } + + return(ptr); } @@ -251,7 +251,7 @@ void* VMem::Realloc(void* block, size_t size) Description : Allocates and clears memory space for an array of objects. Parameters : num (IN) - Specifies the number of objects. - size (IN) - Size of each object. + size (IN) - Size of each object. Returns : Pointer to the allocated memory block. @@ -259,33 +259,33 @@ void* VMem::Realloc(void* block, size_t size) void* VMem::Calloc(size_t num, size_t size) { - void *ptr = NULL; - - if (size <= 0) - return NULL; - - ptr = calloc(num, size); - if (ptr) - { - if(m_allocList) - m_allocList->insert(ptr); - } - else - { - m_dontTouchHashLists = TRUE; - if (m_allocList) - { - m_allocList->forAll(fnFreeMemEntry, (void*) this); - delete m_allocList; - m_allocList = NULL; - } - m_dontTouchHashLists = FALSE; - - // Serious error since memory allocation falied. So, exiting... - ExitThread(TSR_THREAD, 1); - } - - return(ptr); + void *ptr = NULL; + + if (size <= 0) + return NULL; + + ptr = calloc(num, size); + if (ptr) + { + if(m_allocList) + m_allocList->insert(ptr); + } + else + { + m_dontTouchHashLists = TRUE; + if (m_allocList) + { + m_allocList->forAll(fnFreeMemEntry, (void*) this); + delete m_allocList; + m_allocList = NULL; + } + m_dontTouchHashLists = FALSE; + + // Serious error since memory allocation falied. So, exiting... + ExitThread(TSR_THREAD, 1); + } + + return(ptr); } @@ -304,35 +304,35 @@ void* VMem::Calloc(size_t num, size_t size) void VMem::Free(void* p) { - // Final clean up, free all the nodes from the hash list - if (m_dontTouchHashLists) - { - if(p) - { - free(p); - p = NULL; - } - } - else - { - if(p && m_allocList) - { - if (m_allocList->remove(p)) - { - free(p); - p = NULL; - } - else - { - // If it comes here, that means that the memory pointer is not contained in the hash list. - // But no need to free now, since if is deleted here, it will result in an abend!! - // If the memory is still there, it will be cleaned during final cleanup anyway. - } - } - } - - - return; + // Final clean up, free all the nodes from the hash list + if (m_dontTouchHashLists) + { + if(p) + { + free(p); + p = NULL; + } + } + else + { + if(p && m_allocList) + { + if (m_allocList->remove(p)) + { + free(p); + p = NULL; + } + else + { + // If it comes here, that means that the memory pointer is not contained in the hash list. + // But no need to free now, since if is deleted here, it will result in an abend!! + // If the memory is still there, it will be cleaned during final cleanup anyway. + } + } + } + + + return; } diff --git a/NetWare/win32ish.h b/NetWare/win32ish.h index f6603d50f4..7e94a1c0c2 100644 --- a/NetWare/win32ish.h +++ b/NetWare/win32ish.h @@ -22,11 +22,11 @@ #ifndef BOOL - typedef unsigned int BOOL; + typedef unsigned int BOOL; #endif #ifndef DWORD - typedef unsigned long DWORD; + typedef unsigned long DWORD; #endif typedef DWORD LCID; @@ -34,11 +34,11 @@ typedef long HRESULT; typedef void* LPVOID; #ifndef TRUE - #define TRUE 1 + #define TRUE 1 #endif #ifndef FALSE - #define FALSE 0 + #define FALSE 0 #endif diff --git a/Porting/timecheck.c b/Porting/timecheck.c index 87a252d631..9d977ca9f3 100644 --- a/Porting/timecheck.c +++ b/Porting/timecheck.c @@ -17,9 +17,9 @@ static char hexbuf[80]; char *hex (time_t t) { if ((long long)t < 0) - sprintf (hexbuf, " -0x%016lx", -t); + sprintf (hexbuf, " -0x%016lx", -t); else - sprintf (hexbuf, " 0x%016lx", t); + sprintf (hexbuf, " 0x%016lx", t); return (hexbuf); } /* hex */ @@ -27,19 +27,19 @@ void gm_check (time_t t, int min_year, int max_year) { tmp = gmtime (&t); if ( tmp == NULL || - /* Check tm_year overflow */ - tmp->tm_year < min_year || tmp->tm_year > max_year) { - if (opt_v) - fprintf (stderr, "gmtime (%ld) failed with errno %d\n", t, errno); - } + /* Check tm_year overflow */ + tmp->tm_year < min_year || tmp->tm_year > max_year) { + if (opt_v) + fprintf (stderr, "gmtime (%ld) failed with errno %d\n", t, errno); + } else { - if (opt_v) - fprintf (stderr, "%3d:%s: %12ld-%02d-%02d %02d:%02d:%02d\n", - i, hex (t), - (long)(tmp->tm_year) + 1900, tmp->tm_mon + 1, tmp->tm_mday, - tmp->tm_hour, tmp->tm_min, tmp->tm_sec); - pt = t; - } + if (opt_v) + fprintf (stderr, "%3d:%s: %12ld-%02d-%02d %02d:%02d:%02d\n", + i, hex (t), + (long)(tmp->tm_year) + 1900, tmp->tm_mon + 1, tmp->tm_mday, + tmp->tm_hour, tmp->tm_min, tmp->tm_sec); + pt = t; + } } /* gm_check */ int check_gm_max () @@ -47,12 +47,12 @@ int check_gm_max () tmp = NULL; pt = 0; if (tmp == NULL || tmp->tm_year < 0) { - for (i = 63; i >= 0; i--) { - time_t x = pt | ((time_t)1 << i); - if (x < 0 || x < pt) continue; - gm_check (x, 69, 0x7fffffff); - } - } + for (i = 63; i >= 0; i--) { + time_t x = pt | ((time_t)1 << i); + if (x < 0 || x < pt) continue; + gm_check (x, 69, 0x7fffffff); + } + } pt_max = pt; return (0); } /* check_gm_max */ @@ -62,12 +62,12 @@ int check_gm_min () tmp = NULL; pt = 0; if (tmp == NULL) { - for (i = 36; i >= 0; i--) { - time_t x = pt - ((time_t)1 << i); - if (x > 0) continue; - gm_check (x, -1900, 70); - } - } + for (i = 36; i >= 0; i--) { + time_t x = pt - ((time_t)1 << i); + if (x > 0) continue; + gm_check (x, -1900, 70); + } + } pt_min = pt; return (0); } /* check_gm_min */ @@ -75,23 +75,23 @@ int check_gm_min () void lt_check (time_t t, int min_year, int max_year) { if (sizeof (time_t) > 4 && t > 0x7ffffffffffff000LL) - tmp = NULL; + tmp = NULL; else - tmp = localtime (&t); + tmp = localtime (&t); if ( tmp == NULL || - /* Check tm_year overflow */ - tmp->tm_year < min_year || tmp->tm_year > max_year) { - if (opt_v) - fprintf (stderr, "localtime (%ld) failed with errno %d\n", t, errno); - } + /* Check tm_year overflow */ + tmp->tm_year < min_year || tmp->tm_year > max_year) { + if (opt_v) + fprintf (stderr, "localtime (%ld) failed with errno %d\n", t, errno); + } else { - if (opt_v) - fprintf (stderr, "%3d:%s: %12ld-%02d-%02d %02d:%02d:%02d\n", - i, hex (t), - (long)(tmp->tm_year) + 1900, tmp->tm_mon + 1, tmp->tm_mday, - tmp->tm_hour, tmp->tm_min, tmp->tm_sec); - pt = t; - } + if (opt_v) + fprintf (stderr, "%3d:%s: %12ld-%02d-%02d %02d:%02d:%02d\n", + i, hex (t), + (long)(tmp->tm_year) + 1900, tmp->tm_mon + 1, tmp->tm_mday, + tmp->tm_hour, tmp->tm_min, tmp->tm_sec); + pt = t; + } } /* lt_check */ int check_lt_max () @@ -99,12 +99,12 @@ int check_lt_max () tmp = NULL; pt = 0; if (tmp == NULL || tmp->tm_year < 0) { - for (i = 63; i >= 0; i--) { - time_t x = pt | ((time_t)1 << i); - if (x < 0 || x < pt) continue; - lt_check (x, 69, 0x7fffffff); - } - } + for (i = 63; i >= 0; i--) { + time_t x = pt | ((time_t)1 << i); + if (x < 0 || x < pt) continue; + lt_check (x, 69, 0x7fffffff); + } + } pt_max = pt; return (0); } /* check_lt_max */ @@ -114,12 +114,12 @@ int check_lt_min () tmp = NULL; pt = 0; if (tmp == NULL) { - for (i = 36; i >= 0; i--) { - time_t x = pt - ((time_t)1 << i); - if (x > 0) continue; - lt_check (x, -1900, 70); - } - } + for (i = 36; i >= 0; i--) { + time_t x = pt - ((time_t)1 << i); + if (x > 0) continue; + lt_check (x, -1900, 70); + } + } pt_min = pt; return (0); } /* check_lt_min */ diff --git a/Porting/timecheck2.c b/Porting/timecheck2.c index 06d4a66cff..483e152a23 100644 --- a/Porting/timecheck2.c +++ b/Porting/timecheck2.c @@ -10,8 +10,8 @@ time_t Time_Zero = 0; /* Visual C++ 2008's difftime() can't do negative times */ double my_difftime(time_t left, time_t right) { - double diff = (double)left - (double)right; - return diff; + double diff = (double)left - (double)right; + return diff; } void check_date_max( struct tm * (*date_func)(const time_t *), char *func_name ) { diff --git a/amigaos4/amigaio.c b/amigaos4/amigaio.c index 3b5ce0e035..3b2cdcd5e0 100644 --- a/amigaos4/amigaio.c +++ b/amigaos4/amigaio.c @@ -28,244 +28,244 @@ extern int32 myruncommand(BPTR seglist, int stack, char *command, int length, ch void amigaos_stdio_get(pTHX_ StdioStore *store) { - store->astdin = - amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stdingv)))); - store->astderr = - amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stderrgv)))); - store->astdout = amigaos_get_file( - PerlIO_fileno(IoIFP(GvIO(gv_fetchpv("STDOUT", TRUE, SVt_PVIO))))); + store->astdin = + amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stdingv)))); + store->astderr = + amigaos_get_file(PerlIO_fileno(IoIFP(GvIO(PL_stderrgv)))); + store->astdout = amigaos_get_file( + PerlIO_fileno(IoIFP(GvIO(gv_fetchpv("STDOUT", TRUE, SVt_PVIO))))); } void amigaos_stdio_save(pTHX_ StdioStore *store) { - amigaos_stdio_get(aTHX_ store); - store->oldstdin = IDOS->SelectInput(store->astdin); - store->oldstderr = IDOS->SelectErrorOutput(store->astderr); - store->oldstdout = IDOS->SelectOutput(store->astdout); + amigaos_stdio_get(aTHX_ store); + store->oldstdin = IDOS->SelectInput(store->astdin); + store->oldstderr = IDOS->SelectErrorOutput(store->astderr); + store->oldstdout = IDOS->SelectOutput(store->astdout); } void amigaos_stdio_restore(pTHX_ const StdioStore *store) { - IDOS->SelectInput(store->oldstdin); - IDOS->SelectErrorOutput(store->oldstderr); - IDOS->SelectOutput(store->oldstdout); + IDOS->SelectInput(store->oldstdin); + IDOS->SelectErrorOutput(store->oldstderr); + IDOS->SelectOutput(store->oldstdout); } void amigaos_post_exec(int fd, int do_report) { - /* We *must* write something to our pipe or else - * the other end hangs */ - if (do_report) - { - int e = errno; - PerlLIO_write(fd, (void *)&e, sizeof(e)); - PerlLIO_close(fd); - } + /* We *must* write something to our pipe or else + * the other end hangs */ + if (do_report) + { + int e = errno; + PerlLIO_write(fd, (void *)&e, sizeof(e)); + PerlLIO_close(fd); + } } struct popen_data { - struct Task *parent; - STRPTR command; + struct Task *parent; + STRPTR command; }; static int popen_result = 0; int popen_child() { - struct Task *thisTask = IExec->FindTask(0); - struct popen_data *pd = (struct popen_data *)thisTask->tc_UserData; - const char *argv[4]; + struct Task *thisTask = IExec->FindTask(0); + struct popen_data *pd = (struct popen_data *)thisTask->tc_UserData; + const char *argv[4]; - argv[0] = "sh"; - argv[1] = "-c"; - argv[2] = pd->command ? pd->command : NULL; - argv[3] = NULL; + argv[0] = "sh"; + argv[1] = "-c"; + argv[2] = pd->command ? pd->command : NULL; + argv[3] = NULL; - // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,command?command:"NULL"); + // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,command?command:"NULL"); - /* We need to give this to sh via execvp, execvp expects filename, - * argv[] - */ - IExec->ObtainSemaphore(&popen_sema); + /* We need to give this to sh via execvp, execvp expects filename, + * argv[] + */ + IExec->ObtainSemaphore(&popen_sema); - IExec->Signal(pd->parent,SIGBREAKF_CTRL_F); + IExec->Signal(pd->parent,SIGBREAKF_CTRL_F); - popen_result = myexecvp(FALSE, argv[0], (char **)argv); - if (pd->command) - IExec->FreeVec(pd->command); - IExec->FreeVec(pd); + popen_result = myexecvp(FALSE, argv[0], (char **)argv); + if (pd->command) + IExec->FreeVec(pd->command); + IExec->FreeVec(pd); - IExec->ReleaseSemaphore(&popen_sema); - IExec->Forbid(); - return 0; + IExec->ReleaseSemaphore(&popen_sema); + IExec->Forbid(); + return 0; } PerlIO *Perl_my_popen(pTHX_ const char *cmd, const char *mode) { - PERL_FLUSHALL_FOR_CHILD; - PerlIO *result = NULL; - char pipe_name[50]; - char unix_pipe[50]; - char ami_pipe[50]; - BPTR input = 0; - BPTR output = 0; - struct Process *proc = NULL; - struct Task *thisTask = IExec->FindTask(0); - struct popen_data * pd = NULL; - - /* First we need to check the mode - * We can only have unidirectional pipes - */ - // adebug("%s %ld cmd %s mode %s \n",__FUNCTION__,__LINE__,cmd, - // mode); - - switch (mode[0]) - { - case 'r': - case 'w': - break; - - default: - - errno = EINVAL; - return result; - } - - /* Make a unique pipe name - * we need a unix one and an amigaos version (of the same pipe!) - * as were linking with libunix. - */ - - sprintf(pipe_name, "%x%08lx/4096/0", pipenum++, - IUtility->GetUniqueID()); - sprintf(unix_pipe, "/PIPE/%s", pipe_name); - sprintf(ami_pipe, "PIPE:%s", pipe_name); - - /* Now we open the AmigaOs Filehandles That we wil pass to our - * Sub process - */ - - if (mode[0] == 'r') - { - /* A read mode pipe: Output from pipe input from Output() or NIL:*/ - /* First attempt to DUP Output() */ - input = IDOS->DupFileHandle(IDOS->Input()); - if(input == 0) - { - input = IDOS->Open("NIL:", MODE_READWRITE); - } - if (input != 0) - { - output = IDOS->Open(ami_pipe, MODE_NEWFILE); - } - result = PerlIO_open(unix_pipe, mode); - } - else - { - /* Open the write end first! */ - - result = PerlIO_open(unix_pipe, mode); - - input = IDOS->Open(ami_pipe, MODE_OLDFILE); - if (input != 0) - { - output = IDOS->DupFileHandle(IDOS->Output()); - if(output == 0) - { - output = IDOS->Open("NIL:", MODE_READWRITE); - } - } - } - if ((input == 0) || (output == 0) || (result == NULL)) - { - /* Ouch stream opening failed */ - /* Close and bail */ - if (input) - IDOS->Close(input); - if (output) - IDOS->Close(output); - if(result) - { - PerlIO_close(result); - result = NULL; - } - return result; - } - - /* We have our streams now start our new process - * We're using a new process so that execve can modify the environment - * with messing things up for the shell that launched perl - * Copy cmd before we launch the subprocess as perl seems to waste - * no time in overwriting it! The subprocess will free the copy. - */ - - if((pd = (struct popen_data*)IExec->AllocVecTags(sizeof(struct popen_data),AVT_Type,MEMF_SHARED,TAG_DONE))) - { - pd->parent = thisTask; - if ((pd->command = mystrdup(cmd))) - { - // adebug("%s %ld - // %s\n",__FUNCTION__,__LINE__,cmd_copy?cmd_copy:"NULL"); - proc = IDOS->CreateNewProcTags( - NP_Entry, popen_child, NP_Child, TRUE, NP_StackSize, - ((struct Process *)thisTask)->pr_StackSize, NP_Input, input, - NP_Output, output, NP_Error, IDOS->ErrorOutput(), - NP_CloseError, FALSE, NP_Cli, TRUE, NP_Name, - "Perl: popen process", NP_UserData, (int)pd, - TAG_DONE); - } - } - if(proc) - { - /* wait for the child be setup right */ - IExec->Wait(SIGBREAKF_CTRL_F); - } - if (!proc) - { - /* New Process Failed to start - * Close and bail out - */ - if(pd) - { - if(pd->command) - { - IExec->FreeVec(pd->command); - } - IExec->FreeVec(pd); - } - if (input) - IDOS->Close(input); - if (output) - IDOS->Close(output); - if(result) - { - PerlIO_close(result); - result = NULL; - } - } - - /* Our new process is running and will close it streams etc - * once its done. All we need to is open the pipe via stdio - */ - - return result; + PERL_FLUSHALL_FOR_CHILD; + PerlIO *result = NULL; + char pipe_name[50]; + char unix_pipe[50]; + char ami_pipe[50]; + BPTR input = 0; + BPTR output = 0; + struct Process *proc = NULL; + struct Task *thisTask = IExec->FindTask(0); + struct popen_data * pd = NULL; + + /* First we need to check the mode + * We can only have unidirectional pipes + */ + // adebug("%s %ld cmd %s mode %s \n",__FUNCTION__,__LINE__,cmd, + // mode); + + switch (mode[0]) + { + case 'r': + case 'w': + break; + + default: + + errno = EINVAL; + return result; + } + + /* Make a unique pipe name + * we need a unix one and an amigaos version (of the same pipe!) + * as were linking with libunix. + */ + + sprintf(pipe_name, "%x%08lx/4096/0", pipenum++, + IUtility->GetUniqueID()); + sprintf(unix_pipe, "/PIPE/%s", pipe_name); + sprintf(ami_pipe, "PIPE:%s", pipe_name); + + /* Now we open the AmigaOs Filehandles That we wil pass to our + * Sub process + */ + + if (mode[0] == 'r') + { + /* A read mode pipe: Output from pipe input from Output() or NIL:*/ + /* First attempt to DUP Output() */ + input = IDOS->DupFileHandle(IDOS->Input()); + if(input == 0) + { + input = IDOS->Open("NIL:", MODE_READWRITE); + } + if (input != 0) + { + output = IDOS->Open(ami_pipe, MODE_NEWFILE); + } + result = PerlIO_open(unix_pipe, mode); + } + else + { + /* Open the write end first! */ + + result = PerlIO_open(unix_pipe, mode); + + input = IDOS->Open(ami_pipe, MODE_OLDFILE); + if (input != 0) + { + output = IDOS->DupFileHandle(IDOS->Output()); + if(output == 0) + { + output = IDOS->Open("NIL:", MODE_READWRITE); + } + } + } + if ((input == 0) || (output == 0) || (result == NULL)) + { + /* Ouch stream opening failed */ + /* Close and bail */ + if (input) + IDOS->Close(input); + if (output) + IDOS->Close(output); + if(result) + { + PerlIO_close(result); + result = NULL; + } + return result; + } + + /* We have our streams now start our new process + * We're using a new process so that execve can modify the environment + * with messing things up for the shell that launched perl + * Copy cmd before we launch the subprocess as perl seems to waste + * no time in overwriting it! The subprocess will free the copy. + */ + + if((pd = (struct popen_data*)IExec->AllocVecTags(sizeof(struct popen_data),AVT_Type,MEMF_SHARED,TAG_DONE))) + { + pd->parent = thisTask; + if ((pd->command = mystrdup(cmd))) + { + // adebug("%s %ld + // %s\n",__FUNCTION__,__LINE__,cmd_copy?cmd_copy:"NULL"); + proc = IDOS->CreateNewProcTags( + NP_Entry, popen_child, NP_Child, TRUE, NP_StackSize, + ((struct Process *)thisTask)->pr_StackSize, NP_Input, input, + NP_Output, output, NP_Error, IDOS->ErrorOutput(), + NP_CloseError, FALSE, NP_Cli, TRUE, NP_Name, + "Perl: popen process", NP_UserData, (int)pd, + TAG_DONE); + } + } + if(proc) + { + /* wait for the child be setup right */ + IExec->Wait(SIGBREAKF_CTRL_F); + } + if (!proc) + { + /* New Process Failed to start + * Close and bail out + */ + if(pd) + { + if(pd->command) + { + IExec->FreeVec(pd->command); + } + IExec->FreeVec(pd); + } + if (input) + IDOS->Close(input); + if (output) + IDOS->Close(output); + if(result) + { + PerlIO_close(result); + result = NULL; + } + } + + /* Our new process is running and will close it streams etc + * once its done. All we need to is open the pipe via stdio + */ + + return result; } I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { - int result = -1; - /* close the file before obtaining the semaphore else we might end up - hanging waiting for the child to read the last bit from the pipe */ - PerlIO_close(ptr); - IExec->ObtainSemaphore(&popen_sema); - result = popen_result; - IExec->ReleaseSemaphore(&popen_sema); - return result; + int result = -1; + /* close the file before obtaining the semaphore else we might end up + hanging waiting for the child to read the last bit from the pipe */ + PerlIO_close(ptr); + IExec->ObtainSemaphore(&popen_sema); + result = popen_result; + IExec->ReleaseSemaphore(&popen_sema); + return result; } @@ -284,11 +284,11 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) struct thread_info { - pthread_t ti_pid; - int ti_children; - pthread_t ti_parent; - struct MsgPort *ti_port; - struct Process *ti_Process; + pthread_t ti_pid; + int ti_children; + pthread_t ti_parent; + struct MsgPort *ti_port; + struct Process *ti_Process; }; static struct thread_info pseudo_children[MAX_THREADS]; @@ -297,61 +297,61 @@ static struct SignalSemaphore fork_array_sema; void amigaos4_init_fork_array() { - IExec->InitSemaphore(&fork_array_sema); - pseudo_children[0].ti_pid = (pthread_t)IExec->FindTask(0); - pseudo_children[0].ti_parent = -1; - pseudo_children[0].ti_port = - (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE); + IExec->InitSemaphore(&fork_array_sema); + pseudo_children[0].ti_pid = (pthread_t)IExec->FindTask(0); + pseudo_children[0].ti_parent = -1; + pseudo_children[0].ti_port = + (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE); } void amigaos4_dispose_fork_array() { - while (pseudo_children[0].ti_children > 0) - { - void *msg; - IExec->WaitPort(pseudo_children[0].ti_port); - msg = IExec->GetMsg(pseudo_children[0].ti_port); - if (msg) - IExec->FreeSysObject(ASOT_MESSAGE, msg); - pseudo_children[0].ti_children--; - } - IExec->FreeSysObject(ASOT_PORT, pseudo_children[0].ti_port); + while (pseudo_children[0].ti_children > 0) + { + void *msg; + IExec->WaitPort(pseudo_children[0].ti_port); + msg = IExec->GetMsg(pseudo_children[0].ti_port); + if (msg) + IExec->FreeSysObject(ASOT_MESSAGE, msg); + pseudo_children[0].ti_children--; + } + IExec->FreeSysObject(ASOT_PORT, pseudo_children[0].ti_port); } struct thread_exit_message { - struct Message tem_Message; - pthread_t tem_pid; - int tem_status; + struct Message tem_Message; + pthread_t tem_pid; + int tem_status; }; int getnextchild() { - int i; - for (i = 0; i < MAX_THREADS; i++) - { - if (pseudo_children[i].ti_pid == 0) - return i; - } - return -1; + int i; + for (i = 0; i < MAX_THREADS; i++) + { + if (pseudo_children[i].ti_pid == 0) + return i; + } + return -1; } int findparent(pthread_t pid) { - int i; - for (i = 0; i < MAX_THREADS; i++) - { - if (pseudo_children[i].ti_pid == pid) - return i; - } - return -1; + int i; + for (i = 0; i < MAX_THREADS; i++) + { + if (pseudo_children[i].ti_pid == pid) + return i; + } + return -1; } struct child_arg { - struct Task *ca_parent_task; - pthread_t ca_parent; - PerlInterpreter *ca_interp; + struct Task *ca_parent_task; + pthread_t ca_parent; + PerlInterpreter *ca_interp; }; #undef kill @@ -362,202 +362,202 @@ struct child_arg int amigaos_kill(Pid_t pid, int signal) { - int i; - BOOL thistask = FALSE; - Pid_t realpid = pid; // Perhaps we have a real pid from else where? - /* Look for our DOS pid */ - IExec->ObtainSemaphore(&fork_array_sema); - for (i = 0; i < MAX_THREADS; i++) - { - if (pseudo_children[i].ti_pid == pid) - { - realpid = (Pid_t)IDOS->GetPID(pseudo_children[i].ti_Process,GPID_PROCESS); - if(pseudo_children[i].ti_Process == (struct Process *)IExec->FindTask(NULL)) - { - thistask = TRUE; - } - break; - } - } - IExec->ReleaseSemaphore(&fork_array_sema); - /* Allow the C library to work out which signals are realy valid */ - if(thistask) - { - /* A quirk in newlib kill handling means it's better to call raise() rather than kill on out own task. */ - return raise(signal); - } - else - { - return kill(realpid,signal); - } + int i; + BOOL thistask = FALSE; + Pid_t realpid = pid; // Perhaps we have a real pid from else where? + /* Look for our DOS pid */ + IExec->ObtainSemaphore(&fork_array_sema); + for (i = 0; i < MAX_THREADS; i++) + { + if (pseudo_children[i].ti_pid == pid) + { + realpid = (Pid_t)IDOS->GetPID(pseudo_children[i].ti_Process,GPID_PROCESS); + if(pseudo_children[i].ti_Process == (struct Process *)IExec->FindTask(NULL)) + { + thistask = TRUE; + } + break; + } + } + IExec->ReleaseSemaphore(&fork_array_sema); + /* Allow the C library to work out which signals are realy valid */ + if(thistask) + { + /* A quirk in newlib kill handling means it's better to call raise() rather than kill on out own task. */ + return raise(signal); + } + else + { + return kill(realpid,signal); + } } static THREAD_RET_TYPE amigaos4_start_child(void *arg) { - PerlInterpreter *my_perl = - (PerlInterpreter *)((struct child_arg *)arg)->ca_interp; - ; + PerlInterpreter *my_perl = + (PerlInterpreter *)((struct child_arg *)arg)->ca_interp; + ; - GV *tmpgv; - int status; - int parent; - int nextchild; - pthread_t pseudo_id = pthread_self(); + GV *tmpgv; + int status; + int parent; + int nextchild; + pthread_t pseudo_id = pthread_self(); #ifdef PERL_SYNC_FORK - static long sync_fork_id = 0; - long id = ++sync_fork_id; + static long sync_fork_id = 0; + long id = ++sync_fork_id; #endif - /* before we do anything set up our process semaphore and add - a new entry to the pseudochildren */ + /* before we do anything set up our process semaphore and add + a new entry to the pseudochildren */ - /* get next available slot */ - /* should not fail here! */ + /* get next available slot */ + /* should not fail here! */ - IExec->ObtainSemaphore(&fork_array_sema); + IExec->ObtainSemaphore(&fork_array_sema); - nextchild = getnextchild(); + nextchild = getnextchild(); - pseudo_children[nextchild].ti_pid = pseudo_id; - pseudo_children[nextchild].ti_Process = (struct Process *)IExec->FindTask(NULL); - pseudo_children[nextchild].ti_parent = - ((struct child_arg *)arg)->ca_parent; - pseudo_children[nextchild].ti_port = - (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE); + pseudo_children[nextchild].ti_pid = pseudo_id; + pseudo_children[nextchild].ti_Process = (struct Process *)IExec->FindTask(NULL); + pseudo_children[nextchild].ti_parent = + ((struct child_arg *)arg)->ca_parent; + pseudo_children[nextchild].ti_port = + (struct MsgPort *)IExec->AllocSysObjectTags(ASOT_PORT, TAG_DONE); - num_pseudo_children++; - IExec->ReleaseSemaphore(&fork_array_sema); + num_pseudo_children++; + IExec->ReleaseSemaphore(&fork_array_sema); - /* We're set up let the parent continue */ + /* We're set up let the parent continue */ - IExec->Signal(((struct child_arg *)arg)->ca_parent_task, - SIGBREAKF_CTRL_F); + IExec->Signal(((struct child_arg *)arg)->ca_parent_task, + SIGBREAKF_CTRL_F); - PERL_SET_THX(my_perl); - if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) - { - SV *sv = GvSV(tmpgv); - SvREADONLY_off(sv); - sv_setiv(sv, (IV)pseudo_id); - SvREADONLY_on(sv); - } - hv_clear(PL_pidstatus); + PERL_SET_THX(my_perl); + if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) + { + SV *sv = GvSV(tmpgv); + SvREADONLY_off(sv); + sv_setiv(sv, (IV)pseudo_id); + SvREADONLY_on(sv); + } + hv_clear(PL_pidstatus); - /* push a zero on the stack (we are the child) */ - { - dSP; - dTARGET; - PUSHi(0); - PUTBACK; - } + /* push a zero on the stack (we are the child) */ + { + dSP; + dTARGET; + PUSHi(0); + PUTBACK; + } - /* continue from next op */ - PL_op = PL_op->op_next; + /* continue from next op */ + PL_op = PL_op->op_next; - { - dJMPENV; - volatile int oldscope = PL_scopestack_ix; + { + dJMPENV; + volatile int oldscope = PL_scopestack_ix; restart: - JMPENV_PUSH(status); - switch (status) - { - case 0: - CALLRUNOPS(aTHX); - status = 0; - break; - case 2: - while (PL_scopestack_ix > oldscope) - { - LEAVE; - } - FREETMPS; - PL_curstash = PL_defstash; - if (PL_endav && !PL_minus_c) - call_list(oldscope, PL_endav); - status = STATUS_EXIT; - break; - case 3: - if (PL_restartop) - { - POPSTACK_TO(PL_mainstack); - PL_op = PL_restartop; - PL_restartop = (OP *)NULL; - ; - goto restart; - } - PerlIO_printf(Perl_error_log, "panic: restartop\n"); - FREETMPS; - status = 1; - break; - } - JMPENV_POP; - - /* XXX hack to avoid perl_destruct() freeing optree */ - PL_main_root = (OP *)NULL; - } - - { - do_close(PL_stdingv, FALSE); - do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), - FALSE); /* PL_stdoutgv - ISAGN */ - do_close(PL_stderrgv, FALSE); - } - - /* destroy everything (waits for any pseudo-forked children) */ - - /* wait for any remaining children */ - - while (pseudo_children[nextchild].ti_children > 0) - { - if (IExec->WaitPort(pseudo_children[nextchild].ti_port)) - { - void *msg = - IExec->GetMsg(pseudo_children[nextchild].ti_port); - IExec->FreeSysObject(ASOT_MESSAGE, msg); - pseudo_children[nextchild].ti_children--; - } - } - if (PL_scopestack_ix <= 1) - { - perl_destruct(my_perl); - } - perl_free(my_perl); - - IExec->ObtainSemaphore(&fork_array_sema); - parent = findparent(pseudo_children[nextchild].ti_parent); - pseudo_children[nextchild].ti_pid = 0; - pseudo_children[nextchild].ti_parent = 0; - IExec->FreeSysObject(ASOT_PORT, pseudo_children[nextchild].ti_port); - pseudo_children[nextchild].ti_port = NULL; - - IExec->ReleaseSemaphore(&fork_array_sema); - - { - if (parent >= 0) - { - struct thread_exit_message *tem = - (struct thread_exit_message *) - IExec->AllocSysObjectTags( - ASOT_MESSAGE, ASOMSG_Size, - sizeof(struct thread_exit_message), - ASOMSG_Length, - sizeof(struct thread_exit_message)); - if (tem) - { - tem->tem_pid = pseudo_id; - tem->tem_status = status; - IExec->PutMsg(pseudo_children[parent].ti_port, - (struct Message *)tem); - } - } - } + JMPENV_PUSH(status); + switch (status) + { + case 0: + CALLRUNOPS(aTHX); + status = 0; + break; + case 2: + while (PL_scopestack_ix > oldscope) + { + LEAVE; + } + FREETMPS; + PL_curstash = PL_defstash; + if (PL_endav && !PL_minus_c) + call_list(oldscope, PL_endav); + status = STATUS_EXIT; + break; + case 3: + if (PL_restartop) + { + POPSTACK_TO(PL_mainstack); + PL_op = PL_restartop; + PL_restartop = (OP *)NULL; + ; + goto restart; + } + PerlIO_printf(Perl_error_log, "panic: restartop\n"); + FREETMPS; + status = 1; + break; + } + JMPENV_POP; + + /* XXX hack to avoid perl_destruct() freeing optree */ + PL_main_root = (OP *)NULL; + } + + { + do_close(PL_stdingv, FALSE); + do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), + FALSE); /* PL_stdoutgv - ISAGN */ + do_close(PL_stderrgv, FALSE); + } + + /* destroy everything (waits for any pseudo-forked children) */ + + /* wait for any remaining children */ + + while (pseudo_children[nextchild].ti_children > 0) + { + if (IExec->WaitPort(pseudo_children[nextchild].ti_port)) + { + void *msg = + IExec->GetMsg(pseudo_children[nextchild].ti_port); + IExec->FreeSysObject(ASOT_MESSAGE, msg); + pseudo_children[nextchild].ti_children--; + } + } + if (PL_scopestack_ix <= 1) + { + perl_destruct(my_perl); + } + perl_free(my_perl); + + IExec->ObtainSemaphore(&fork_array_sema); + parent = findparent(pseudo_children[nextchild].ti_parent); + pseudo_children[nextchild].ti_pid = 0; + pseudo_children[nextchild].ti_parent = 0; + IExec->FreeSysObject(ASOT_PORT, pseudo_children[nextchild].ti_port); + pseudo_children[nextchild].ti_port = NULL; + + IExec->ReleaseSemaphore(&fork_array_sema); + + { + if (parent >= 0) + { + struct thread_exit_message *tem = + (struct thread_exit_message *) + IExec->AllocSysObjectTags( + ASOT_MESSAGE, ASOMSG_Size, + sizeof(struct thread_exit_message), + ASOMSG_Length, + sizeof(struct thread_exit_message)); + if (tem) + { + tem->tem_pid = pseudo_id; + tem->tem_status = status; + IExec->PutMsg(pseudo_children[parent].ti_port, + (struct Message *)tem); + } + } + } #ifdef PERL_SYNC_FORK - return id; + return id; #else - return (void *)status; + return (void *)status; #endif } @@ -565,61 +565,61 @@ restart: Pid_t amigaos_fork() { - dTHX; - pthread_t id; - int handle; - struct child_arg arg; - if (num_pseudo_children >= MAX_THREADS) - { - errno = EAGAIN; - return -1; - } - arg.ca_interp = perl_clone((PerlInterpreter *)aTHX, CLONEf_COPY_STACKS); - arg.ca_parent_task = IExec->FindTask(NULL); - arg.ca_parent = - pthread_self() ? pthread_self() : (pthread_t)IExec->FindTask(0); - - handle = pthread_create(&id, NULL, amigaos4_start_child, (void *)&arg); - pseudo_children[findparent(arg.ca_parent)].ti_children++; - - IExec->Wait(SIGBREAKF_CTRL_F); - - PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */ - if (handle) - { - errno = EAGAIN; - return -1; - } - return id; + dTHX; + pthread_t id; + int handle; + struct child_arg arg; + if (num_pseudo_children >= MAX_THREADS) + { + errno = EAGAIN; + return -1; + } + arg.ca_interp = perl_clone((PerlInterpreter *)aTHX, CLONEf_COPY_STACKS); + arg.ca_parent_task = IExec->FindTask(NULL); + arg.ca_parent = + pthread_self() ? pthread_self() : (pthread_t)IExec->FindTask(0); + + handle = pthread_create(&id, NULL, amigaos4_start_child, (void *)&arg); + pseudo_children[findparent(arg.ca_parent)].ti_children++; + + IExec->Wait(SIGBREAKF_CTRL_F); + + PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */ + if (handle) + { + errno = EAGAIN; + return -1; + } + return id; } Pid_t amigaos_waitpid(pTHX_ int optype, Pid_t pid, void *argflags) { - int result; - if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) - { - result = pthread_join(pid, (void **)argflags); - } - else - { - while ((result = pthread_join(pid, (void **)argflags)) == -1 && - errno == EINTR) - { - // PERL_ASYNC_CHECK(); - } - } - return result; + int result; + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + { + result = pthread_join(pid, (void **)argflags); + } + else + { + while ((result = pthread_join(pid, (void **)argflags)) == -1 && + errno == EINTR) + { + // PERL_ASYNC_CHECK(); + } + } + return result; } void amigaos_fork_set_userdata( pTHX_ struct UserData *userdata, I32 did_pipes, int pp, SV **sp, SV **mark) { - userdata->parent = IExec->FindTask(0); - userdata->did_pipes = did_pipes; - userdata->pp = pp; - userdata->sp = sp; - userdata->mark = mark; - userdata->my_perl = aTHX; + userdata->parent = IExec->FindTask(0); + userdata->did_pipes = did_pipes; + userdata->pp = pp; + userdata->sp = sp; + userdata->mark = mark; + userdata->my_perl = aTHX; } /* AmigaOS specific versions of #?exec#? solely for use in amigaos_system_child @@ -627,275 +627,275 @@ void amigaos_fork_set_userdata( static void S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) { - const int e = errno; + const int e = errno; // PERL_ARGS_ASSERT_EXEC_FAILED; - if (e) - { - if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), - "Can't exec \"%s\": %s", cmd, Strerror(e)); - } - if (do_report) - { - /* XXX silently ignore failures */ - PERL_UNUSED_RESULT(PerlLIO_write(fd, (void *)&e, sizeof(int))); - PerlLIO_close(fd); - } + if (e) + { + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), + "Can't exec \"%s\": %s", cmd, Strerror(e)); + } + if (do_report) + { + /* XXX silently ignore failures */ + PERL_UNUSED_RESULT(PerlLIO_write(fd, (void *)&e, sizeof(int))); + PerlLIO_close(fd); + } } static I32 S_do_amigaos_exec3(pTHX_ const char *incmd, int fd, int do_report) { - const char **argv, **a; - char *s; - char *buf; - char *cmd; - /* Make a copy so we can change it */ - const Size_t cmdlen = strlen(incmd) + 1; - I32 result = -1; - - PERL_ARGS_ASSERT_DO_EXEC3; - - ENTER; - Newx(buf, cmdlen, char); - SAVEFREEPV(buf); - cmd = buf; - memcpy(cmd, incmd, cmdlen); - - while (*cmd && isSPACE(*cmd)) - cmd++; - - /* see if there are shell metacharacters in it */ - - if (*cmd == '.' && isSPACE(cmd[1])) - goto doshell; - - if (strBEGINs(cmd, "exec") && isSPACE(cmd[4])) - goto doshell; - - s = cmd; - while (isWORDCHAR(*s)) - s++; /* catch VAR=val gizmo */ - if (*s == '=') - goto doshell; - - for (s = cmd; *s; s++) - { - if (*s != ' ' && !isALPHA(*s) && - memCHRs("$&*(){}[]'\";\\|?<>~`\n", *s)) - { - if (*s == '\n' && !s[1]) - { - *s = '\0'; - break; - } - /* handle the 2>&1 construct at the end */ - if (*s == '>' && s[1] == '&' && s[2] == '1' && - s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) && - (!s[3] || isSPACE(s[3]))) - { - const char *t = s + 3; - - while (*t && isSPACE(*t)) - ++t; - if (!*t && (PerlLIO_dup2(1, 2) != -1)) - { - s[-2] = '\0'; - break; - } - } + const char **argv, **a; + char *s; + char *buf; + char *cmd; + /* Make a copy so we can change it */ + const Size_t cmdlen = strlen(incmd) + 1; + I32 result = -1; + + PERL_ARGS_ASSERT_DO_EXEC3; + + ENTER; + Newx(buf, cmdlen, char); + SAVEFREEPV(buf); + cmd = buf; + memcpy(cmd, incmd, cmdlen); + + while (*cmd && isSPACE(*cmd)) + cmd++; + + /* see if there are shell metacharacters in it */ + + if (*cmd == '.' && isSPACE(cmd[1])) + goto doshell; + + if (strBEGINs(cmd, "exec") && isSPACE(cmd[4])) + goto doshell; + + s = cmd; + while (isWORDCHAR(*s)) + s++; /* catch VAR=val gizmo */ + if (*s == '=') + goto doshell; + + for (s = cmd; *s; s++) + { + if (*s != ' ' && !isALPHA(*s) && + memCHRs("$&*(){}[]'\";\\|?<>~`\n", *s)) + { + if (*s == '\n' && !s[1]) + { + *s = '\0'; + break; + } + /* handle the 2>&1 construct at the end */ + if (*s == '>' && s[1] == '&' && s[2] == '1' && + s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) && + (!s[3] || isSPACE(s[3]))) + { + const char *t = s + 3; + + while (*t && isSPACE(*t)) + ++t; + if (!*t && (PerlLIO_dup2(1, 2) != -1)) + { + s[-2] = '\0'; + break; + } + } doshell: - PERL_FPU_PRE_EXEC - result = myexecl(FALSE, PL_sh_path, "sh", "-c", cmd, - (char *)NULL); - PERL_FPU_POST_EXEC - S_exec_failed(aTHX_ PL_sh_path, fd, do_report); - amigaos_post_exec(fd, do_report); - goto leave; - } - } - - Newx(argv, (s - cmd) / 2 + 2, const char *); - SAVEFREEPV(argv); - cmd = savepvn(cmd, s - cmd); - SAVEFREEPV(cmd); - a = argv; - for (s = cmd; *s;) - { - while (isSPACE(*s)) - s++; - if (*s) - *(a++) = s; - while (*s && !isSPACE(*s)) - s++; - if (*s) - *s++ = '\0'; - } - *a = NULL; - if (argv[0]) - { - PERL_FPU_PRE_EXEC - result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv)); - PERL_FPU_POST_EXEC - if (errno == ENOEXEC) /* for system V NIH syndrome */ - goto doshell; - S_exec_failed(aTHX_ argv[0], fd, do_report); - amigaos_post_exec(fd, do_report); - } + PERL_FPU_PRE_EXEC + result = myexecl(FALSE, PL_sh_path, "sh", "-c", cmd, + (char *)NULL); + PERL_FPU_POST_EXEC + S_exec_failed(aTHX_ PL_sh_path, fd, do_report); + amigaos_post_exec(fd, do_report); + goto leave; + } + } + + Newx(argv, (s - cmd) / 2 + 2, const char *); + SAVEFREEPV(argv); + cmd = savepvn(cmd, s - cmd); + SAVEFREEPV(cmd); + a = argv; + for (s = cmd; *s;) + { + while (isSPACE(*s)) + s++; + if (*s) + *(a++) = s; + while (*s && !isSPACE(*s)) + s++; + if (*s) + *s++ = '\0'; + } + *a = NULL; + if (argv[0]) + { + PERL_FPU_PRE_EXEC + result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv)); + PERL_FPU_POST_EXEC + if (errno == ENOEXEC) /* for system V NIH syndrome */ + goto doshell; + S_exec_failed(aTHX_ argv[0], fd, do_report); + amigaos_post_exec(fd, do_report); + } leave: - LEAVE; - return result; + LEAVE; + return result; } I32 S_do_amigaos_aexec5( pTHX_ SV *really, SV **mark, SV **sp, int fd, int do_report) { - I32 result = -1; - PERL_ARGS_ASSERT_DO_AEXEC5; - ENTER; - if (sp > mark) - { - const char **argv, **a; - const char *tmps = NULL; - Newx(argv, sp - mark + 1, const char *); - SAVEFREEPV(argv); - a = argv; - - while (++mark <= sp) - { - if (*mark) { - char *arg = savepv(SvPV_nolen_const(*mark)); - SAVEFREEPV(arg); - *a++ = arg; - } else - *a++ = ""; - } - *a = NULL; - if (really) { - tmps = savepv(SvPV_nolen_const(really)); - SAVEFREEPV(tmps); - } - if ((!really && *argv[0] != '/') || - (really && *tmps != '/')) /* will execvp use PATH? */ - TAINT_ENV(); /* testing IFS here is overkill, probably + I32 result = -1; + PERL_ARGS_ASSERT_DO_AEXEC5; + ENTER; + if (sp > mark) + { + const char **argv, **a; + const char *tmps = NULL; + Newx(argv, sp - mark + 1, const char *); + SAVEFREEPV(argv); + a = argv; + + while (++mark <= sp) + { + if (*mark) { + char *arg = savepv(SvPV_nolen_const(*mark)); + SAVEFREEPV(arg); + *a++ = arg; + } else + *a++ = ""; + } + *a = NULL; + if (really) { + tmps = savepv(SvPV_nolen_const(really)); + SAVEFREEPV(tmps); + } + if ((!really && *argv[0] != '/') || + (really && *tmps != '/')) /* will execvp use PATH? */ + TAINT_ENV(); /* testing IFS here is overkill, probably */ - PERL_FPU_PRE_EXEC - if (really && *tmps) - { - result = myexecvp(FALSE, tmps, EXEC_ARGV_CAST(argv)); - } - else - { - result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv)); - } - PERL_FPU_POST_EXEC - S_exec_failed(aTHX_(really ? tmps : argv[0]), fd, do_report); - } - amigaos_post_exec(fd, do_report); - LEAVE; - return result; + PERL_FPU_PRE_EXEC + if (really && *tmps) + { + result = myexecvp(FALSE, tmps, EXEC_ARGV_CAST(argv)); + } + else + { + result = myexecvp(FALSE, argv[0], EXEC_ARGV_CAST(argv)); + } + PERL_FPU_POST_EXEC + S_exec_failed(aTHX_(really ? tmps : argv[0]), fd, do_report); + } + amigaos_post_exec(fd, do_report); + LEAVE; + return result; } void *amigaos_system_child(void *userdata) { - struct Task *parent; - I32 did_pipes; - int pp; - I32 value; - STRLEN n_a; - /* these next are declared by macros else where but I may be - * passing modified values here so declare them explictly but - * still referred to by macro below */ - - register SV **sp; - register SV **mark; - register PerlInterpreter *my_perl; - - StdioStore store; - - struct UserData *ud = (struct UserData *)userdata; - - did_pipes = ud->did_pipes; - parent = ud->parent; - pp = ud->pp; - SP = ud->sp; - MARK = ud->mark; - my_perl = ud->my_perl; - PERL_SET_THX(my_perl); - - amigaos_stdio_save(aTHX_ & store); - - if (did_pipes) - { - // PerlLIO_close(pp[0]); - } - if (PL_op->op_flags & OPf_STACKED) - { - SV *really = *++MARK; - value = (I32)S_do_amigaos_aexec5(aTHX_ really, MARK, SP, pp, - did_pipes); - } - else if (SP - MARK != 1) - { - value = (I32)S_do_amigaos_aexec5(aTHX_ NULL, MARK, SP, pp, - did_pipes); - } - else - { - value = (I32)S_do_amigaos_exec3( - aTHX_ SvPVx(sv_mortalcopy(*SP), n_a), pp, did_pipes); - } - - // Forbid(); - // Signal(parent, SIGBREAKF_CTRL_F); - - amigaos_stdio_restore(aTHX_ & store); - - return (void *)value; + struct Task *parent; + I32 did_pipes; + int pp; + I32 value; + STRLEN n_a; + /* these next are declared by macros else where but I may be + * passing modified values here so declare them explictly but + * still referred to by macro below */ + + register SV **sp; + register SV **mark; + register PerlInterpreter *my_perl; + + StdioStore store; + + struct UserData *ud = (struct UserData *)userdata; + + did_pipes = ud->did_pipes; + parent = ud->parent; + pp = ud->pp; + SP = ud->sp; + MARK = ud->mark; + my_perl = ud->my_perl; + PERL_SET_THX(my_perl); + + amigaos_stdio_save(aTHX_ & store); + + if (did_pipes) + { + // PerlLIO_close(pp[0]); + } + if (PL_op->op_flags & OPf_STACKED) + { + SV *really = *++MARK; + value = (I32)S_do_amigaos_aexec5(aTHX_ really, MARK, SP, pp, + did_pipes); + } + else if (SP - MARK != 1) + { + value = (I32)S_do_amigaos_aexec5(aTHX_ NULL, MARK, SP, pp, + did_pipes); + } + else + { + value = (I32)S_do_amigaos_exec3( + aTHX_ SvPVx(sv_mortalcopy(*SP), n_a), pp, did_pipes); + } + + // Forbid(); + // Signal(parent, SIGBREAKF_CTRL_F); + + amigaos_stdio_restore(aTHX_ & store); + + return (void *)value; } static BOOL contains_whitespace(char *string) { - if (string) - { - - if (strchr(string, ' ')) - return TRUE; - if (strchr(string, '\t')) - return TRUE; - if (strchr(string, '\n')) - return TRUE; - if (strchr(string, 0xA0)) - return TRUE; - if (strchr(string, '"')) - return TRUE; - } - return FALSE; + if (string) + { + + if (strchr(string, ' ')) + return TRUE; + if (strchr(string, '\t')) + return TRUE; + if (strchr(string, '\n')) + return TRUE; + if (strchr(string, 0xA0)) + return TRUE; + if (strchr(string, '"')) + return TRUE; + } + return FALSE; } static int no_of_escapes(char *string) { - int cnt = 0; - char *p; - for (p = string; p < string + strlen(string); p++) - { - if (*p == '"') - cnt++; - if (*p == '*') - cnt++; - if (*p == '\n') - cnt++; - if (*p == '\t') - cnt++; - } - return cnt; + int cnt = 0; + char *p; + for (p = string; p < string + strlen(string); p++) + { + if (*p == '"') + cnt++; + if (*p == '*') + cnt++; + if (*p == '\n') + cnt++; + if (*p == '\t') + cnt++; + } + return cnt; } struct command_data { - STRPTR args; - BPTR seglist; - struct Task *parent; + STRPTR args; + BPTR seglist; + struct Task *parent; }; #undef fopen @@ -910,262 +910,262 @@ int myexecve(bool isperlthread, char *argv[], char *envp[]) { - FILE *fh; - char buffer[1000]; - int size = 0; - char **cur; - char *interpreter = 0; - char *interpreter_args = 0; - char *full = 0; - char *filename_conv = 0; - char *interpreter_conv = 0; - // char *tmp = 0; - char *fname; - // int tmpint; - // struct Task *thisTask = IExec->FindTask(0); - int result = -1; - - StdioStore store; - - pTHX = NULL; - - if (isperlthread) - { - aTHX = PERL_GET_THX; - /* Save away our stdio */ - amigaos_stdio_save(aTHX_ & store); - } - - // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,filename?filename:"NULL"); - - /* Calculate the size of filename and all args, including spaces and - * quotes */ - size = 0; // strlen(filename) + 1; - for (cur = (char **)argv /* +1 */; *cur; cur++) - { - size += - strlen(*cur) + 1 + - (contains_whitespace(*cur) ? (2 + no_of_escapes(*cur)) : 0); - } - /* Check if it's a script file */ - IExec->DebugPrintF("%s %ld %08lx %c %c\n",__FILE__,__LINE__,filename,filename[0],filename[1]); - fh = fopen(filename, "r"); - if (fh) - { - if (fgetc(fh) == '#' && fgetc(fh) == '!') - { - char *p; - char *q; - fgets(buffer, 999, fh); - p = buffer; - while (*p == ' ' || *p == '\t') - p++; - if (buffer[strlen(buffer) - 1] == '\n') - buffer[strlen(buffer) - 1] = '\0'; - if ((q = strchr(p, ' '))) - { - *q++ = '\0'; - if (*q != '\0') - { - interpreter_args = mystrdup(q); - } - } - else - interpreter_args = mystrdup(""); - - interpreter = mystrdup(p); - size += strlen(interpreter) + 1; - size += strlen(interpreter_args) + 1; - } - - fclose(fh); - } - else - { - /* We couldn't open this why not? */ - if (errno == ENOENT) - { - /* file didn't exist! */ - goto out; - } - } - - /* Allocate the command line */ - filename_conv = convert_path_u2a(filename); - - if (filename_conv) - size += strlen(filename_conv); - size += 1; - full = (char *)IExec->AllocVecTags(size + 10, AVT_ClearWithValue, 0 ,TAG_DONE); - if (full) - { - if (interpreter) - { - interpreter_conv = convert_path_u2a(interpreter); + FILE *fh; + char buffer[1000]; + int size = 0; + char **cur; + char *interpreter = 0; + char *interpreter_args = 0; + char *full = 0; + char *filename_conv = 0; + char *interpreter_conv = 0; + // char *tmp = 0; + char *fname; + // int tmpint; + // struct Task *thisTask = IExec->FindTask(0); + int result = -1; + + StdioStore store; + + pTHX = NULL; + + if (isperlthread) + { + aTHX = PERL_GET_THX; + /* Save away our stdio */ + amigaos_stdio_save(aTHX_ & store); + } + + // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,filename?filename:"NULL"); + + /* Calculate the size of filename and all args, including spaces and + * quotes */ + size = 0; // strlen(filename) + 1; + for (cur = (char **)argv /* +1 */; *cur; cur++) + { + size += + strlen(*cur) + 1 + + (contains_whitespace(*cur) ? (2 + no_of_escapes(*cur)) : 0); + } + /* Check if it's a script file */ + IExec->DebugPrintF("%s %ld %08lx %c %c\n",__FILE__,__LINE__,filename,filename[0],filename[1]); + fh = fopen(filename, "r"); + if (fh) + { + if (fgetc(fh) == '#' && fgetc(fh) == '!') + { + char *p; + char *q; + fgets(buffer, 999, fh); + p = buffer; + while (*p == ' ' || *p == '\t') + p++; + if (buffer[strlen(buffer) - 1] == '\n') + buffer[strlen(buffer) - 1] = '\0'; + if ((q = strchr(p, ' '))) + { + *q++ = '\0'; + if (*q != '\0') + { + interpreter_args = mystrdup(q); + } + } + else + interpreter_args = mystrdup(""); + + interpreter = mystrdup(p); + size += strlen(interpreter) + 1; + size += strlen(interpreter_args) + 1; + } + + fclose(fh); + } + else + { + /* We couldn't open this why not? */ + if (errno == ENOENT) + { + /* file didn't exist! */ + goto out; + } + } + + /* Allocate the command line */ + filename_conv = convert_path_u2a(filename); + + if (filename_conv) + size += strlen(filename_conv); + size += 1; + full = (char *)IExec->AllocVecTags(size + 10, AVT_ClearWithValue, 0 ,TAG_DONE); + if (full) + { + if (interpreter) + { + interpreter_conv = convert_path_u2a(interpreter); #if !defined(__USE_RUNCOMMAND__) #warning(using system!) - sprintf(full, "%s %s %s ", interpreter_conv, - interpreter_args, filename_conv); + sprintf(full, "%s %s %s ", interpreter_conv, + interpreter_args, filename_conv); #else - sprintf(full, "%s %s ", interpreter_args, - filename_conv); + sprintf(full, "%s %s ", interpreter_args, + filename_conv); #endif - IExec->FreeVec(interpreter); - IExec->FreeVec(interpreter_args); - - if (filename_conv) - IExec->FreeVec(filename_conv); - fname = mystrdup(interpreter_conv); - - if (interpreter_conv) - IExec->FreeVec(interpreter_conv); - } - else - { + IExec->FreeVec(interpreter); + IExec->FreeVec(interpreter_args); + + if (filename_conv) + IExec->FreeVec(filename_conv); + fname = mystrdup(interpreter_conv); + + if (interpreter_conv) + IExec->FreeVec(interpreter_conv); + } + else + { #ifndef __USE_RUNCOMMAND__ - sprintf(full, "%s ", filename_conv); + sprintf(full, "%s ", filename_conv); #else - sprintf(full, ""); + sprintf(full, ""); #endif - fname = mystrdup(filename_conv); - if (filename_conv) - IExec->FreeVec(filename_conv); - } - - for (cur = (char **)(argv + 1); *cur != 0; cur++) - { - if (contains_whitespace(*cur)) - { - int esc = no_of_escapes(*cur); - - if (esc > 0) - { - char *buff = (char *)IExec->AllocVecTags( - strlen(*cur) + 4 + esc, - AVT_ClearWithValue,0, - TAG_DONE); - char *p = *cur; - char *q = buff; - - *q++ = '"'; - while (*p != '\0') - { - - if (*p == '\n') - { - *q++ = '*'; - *q++ = 'N'; - p++; - continue; - } - else if (*p == '"') - { - *q++ = '*'; - *q++ = '"'; - p++; - continue; - } - else if (*p == '*') - { - *q++ = '*'; - } - *q++ = *p++; - } - *q++ = '"'; - *q++ = ' '; - *q = '\0'; - strcat(full, buff); - IExec->FreeVec(buff); - } - else - { - strcat(full, "\""); - strcat(full, *cur); - strcat(full, "\" "); - } - } - else - { - strcat(full, *cur); - strcat(full, " "); - } - } - strcat(full, "\n"); + fname = mystrdup(filename_conv); + if (filename_conv) + IExec->FreeVec(filename_conv); + } + + for (cur = (char **)(argv + 1); *cur != 0; cur++) + { + if (contains_whitespace(*cur)) + { + int esc = no_of_escapes(*cur); + + if (esc > 0) + { + char *buff = (char *)IExec->AllocVecTags( + strlen(*cur) + 4 + esc, + AVT_ClearWithValue,0, + TAG_DONE); + char *p = *cur; + char *q = buff; + + *q++ = '"'; + while (*p != '\0') + { + + if (*p == '\n') + { + *q++ = '*'; + *q++ = 'N'; + p++; + continue; + } + else if (*p == '"') + { + *q++ = '*'; + *q++ = '"'; + p++; + continue; + } + else if (*p == '*') + { + *q++ = '*'; + } + *q++ = *p++; + } + *q++ = '"'; + *q++ = ' '; + *q = '\0'; + strcat(full, buff); + IExec->FreeVec(buff); + } + else + { + strcat(full, "\""); + strcat(full, *cur); + strcat(full, "\" "); + } + } + else + { + strcat(full, *cur); + strcat(full, " "); + } + } + strcat(full, "\n"); // if(envp) // createvars(envp); #ifndef __USE_RUNCOMMAND__ - result = IDOS->SystemTags( - full, SYS_UserShell, TRUE, NP_StackSize, - ((struct Process *)thisTask)->pr_StackSize, SYS_Input, - ((struct Process *)thisTask)->pr_CIS, SYS_Output, - ((struct Process *)thisTask)->pr_COS, SYS_Error, - ((struct Process *)thisTask)->pr_CES, TAG_DONE); + result = IDOS->SystemTags( + full, SYS_UserShell, TRUE, NP_StackSize, + ((struct Process *)thisTask)->pr_StackSize, SYS_Input, + ((struct Process *)thisTask)->pr_CIS, SYS_Output, + ((struct Process *)thisTask)->pr_COS, SYS_Error, + ((struct Process *)thisTask)->pr_CES, TAG_DONE); #else - if (fname) - { - BPTR seglist = IDOS->LoadSeg(fname); - if (seglist) - { - /* check if we have an executable! */ - struct PseudoSegList *ps = NULL; - if (!IDOS->GetSegListInfoTags( - seglist, GSLI_Native, &ps, TAG_DONE)) - { - IDOS->GetSegListInfoTags( - seglist, GSLI_68KPS, &ps, TAG_DONE); - } - if (ps != NULL) - { - // adebug("%s %ld %s - // %s\n",__FUNCTION__,__LINE__,fname,full); - IDOS->SetCliProgramName(fname); - // result=RunCommand(seglist,8*1024,full,strlen(full)); - // result=myruncommand(seglist,8*1024,full,strlen(full),envp); - result = myruncommand(seglist, 8 * 1024, - full, -1, envp); - errno = 0; - } - else - { - errno = ENOEXEC; - } - IDOS->UnLoadSeg(seglist); - } - else - { - errno = ENOEXEC; - } - IExec->FreeVec(fname); - } + if (fname) + { + BPTR seglist = IDOS->LoadSeg(fname); + if (seglist) + { + /* check if we have an executable! */ + struct PseudoSegList *ps = NULL; + if (!IDOS->GetSegListInfoTags( + seglist, GSLI_Native, &ps, TAG_DONE)) + { + IDOS->GetSegListInfoTags( + seglist, GSLI_68KPS, &ps, TAG_DONE); + } + if (ps != NULL) + { + // adebug("%s %ld %s + // %s\n",__FUNCTION__,__LINE__,fname,full); + IDOS->SetCliProgramName(fname); + // result=RunCommand(seglist,8*1024,full,strlen(full)); + // result=myruncommand(seglist,8*1024,full,strlen(full),envp); + result = myruncommand(seglist, 8 * 1024, + full, -1, envp); + errno = 0; + } + else + { + errno = ENOEXEC; + } + IDOS->UnLoadSeg(seglist); + } + else + { + errno = ENOEXEC; + } + IExec->FreeVec(fname); + } #endif /* USE_RUNCOMMAND */ - IExec->FreeVec(full); - if (errno == ENOEXEC) - { - result = -1; - } - goto out; - } + IExec->FreeVec(full); + if (errno == ENOEXEC) + { + result = -1; + } + goto out; + } - if (interpreter) - IExec->FreeVec(interpreter); - if (filename_conv) - IExec->FreeVec(filename_conv); + if (interpreter) + IExec->FreeVec(interpreter); + if (filename_conv) + IExec->FreeVec(filename_conv); - errno = ENOMEM; + errno = ENOMEM; out: - if (isperlthread) - { - amigaos_stdio_restore(aTHX_ & store); - STATUS_NATIVE_CHILD_SET(result); - PL_exit_flags |= PERL_EXIT_EXPECTED; - if (result != -1) - my_exit(result); - } - return (result); + if (isperlthread) + { + amigaos_stdio_restore(aTHX_ & store); + STATUS_NATIVE_CHILD_SET(result); + PL_exit_flags |= PERL_EXIT_EXPECTED; + if (result != -1) + my_exit(result); + } + return (result); } diff --git a/amigaos4/amigaio.h b/amigaos4/amigaio.h index 1f1a53a0de..0385ce14bd 100644 --- a/amigaos4/amigaio.h +++ b/amigaos4/amigaio.h @@ -7,14 +7,14 @@ struct StdioStore { - /* astdin...astderr are the amigaos file descriptors */ - long astdin; - long astdout; - long astderr; - /* oldstdin...oldstderr are the amigados file handles */ - long oldstdin; - long oldstdout; - long oldstderr; + /* astdin...astderr are the amigaos file descriptors */ + long astdin; + long astdout; + long astderr; + /* oldstdin...oldstderr are the amigados file handles */ + long oldstdin; + long oldstdout; + long oldstderr; }; typedef struct StdioStore StdioStore; @@ -32,12 +32,12 @@ void amigaos_stdio_restore(pTHX_ const StdioStore *store); * then pass it through task->tc_UserData or as arg to new pthread */ struct UserData { - struct Task *parent; - I32 did_pipes; - int pp; - SV **sp; - SV **mark; - PerlInterpreter *my_perl; + struct Task *parent; + I32 did_pipes; + int pp; + SV **sp; + SV **mark; + PerlInterpreter *my_perl; }; void amigaos_fork_set_userdata( diff --git a/amigaos4/amigaos.c b/amigaos4/amigaos.c index 7d432d9dfc..cf5967315f 100644 --- a/amigaos4/amigaos.c +++ b/amigaos4/amigaos.c @@ -36,28 +36,28 @@ struct UtilityIFace *IUtility = NULL; struct Interface *OpenInterface(CONST_STRPTR libname, uint32 libver) { - struct Library *base = IExec->OpenLibrary(libname, libver); - struct Interface *iface = IExec->GetInterface(base, "main", 1, NULL); - if (iface == NULL) - { - // We should probably post some kind of error message here. + struct Library *base = IExec->OpenLibrary(libname, libver); + struct Interface *iface = IExec->GetInterface(base, "main", 1, NULL); + if (iface == NULL) + { + // We should probably post some kind of error message here. - IExec->CloseLibrary(base); - } + IExec->CloseLibrary(base); + } - return iface; + return iface; } /***************************************************************************/ void CloseInterface(struct Interface *iface) { - if (iface != NULL) - { - struct Library *base = iface->Data.LibBase; - IExec->DropInterface(iface); - IExec->CloseLibrary(base); - } + if (iface != NULL) + { + struct Library *base = iface->Data.LibBase; + IExec->DropInterface(iface); + IExec->CloseLibrary(base); + } } BOOL __unlink_retries = FALSE; @@ -70,17 +70,17 @@ void ___closeinterfaces() __attribute__((destructor)); void ___openinterfaces() { - if (!IDOS) - IDOS = (struct DOSIFace *)OpenInterface("dos.library", 53); - if (!IUtility) - IUtility = - (struct UtilityIFace *)OpenInterface("utility.library", 53); + if (!IDOS) + IDOS = (struct DOSIFace *)OpenInterface("dos.library", 53); + if (!IUtility) + IUtility = + (struct UtilityIFace *)OpenInterface("utility.library", 53); } void ___closeinterfaces() { - CloseInterface((struct Interface *)IDOS); - CloseInterface((struct Interface *)IUtility); + CloseInterface((struct Interface *)IDOS); + CloseInterface((struct Interface *)IUtility); } int VARARGS68K araddebug(UBYTE *fmt, ...); int VARARGS68K adebug(UBYTE *fmt, ...); @@ -94,150 +94,150 @@ static void createvars(char **envp); struct args { - BPTR seglist; - int stack; - char *command; - int length; - int result; - char **envp; + BPTR seglist; + int stack; + char *command; + int length; + int result; + char **envp; }; int __myrc(__attribute__((unused))char *arg) { - struct Task *thisTask = IExec->FindTask(0); - struct args *myargs = (struct args *)thisTask->tc_UserData; - if (myargs->envp) - createvars(myargs->envp); - // adebug("%s %ld %s \n",__FUNCTION__,__LINE__,myargs->command); - myargs->result = IDOS->RunCommand(myargs->seglist, myargs->stack, - myargs->command, myargs->length); - return 0; + struct Task *thisTask = IExec->FindTask(0); + struct args *myargs = (struct args *)thisTask->tc_UserData; + if (myargs->envp) + createvars(myargs->envp); + // adebug("%s %ld %s \n",__FUNCTION__,__LINE__,myargs->command); + myargs->result = IDOS->RunCommand(myargs->seglist, myargs->stack, + myargs->command, myargs->length); + return 0; } int32 myruncommand( BPTR seglist, int stack, char *command, int length, char **envp) { - struct args myargs; - struct Task *thisTask = IExec->FindTask(0); - struct Process *proc; - - // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,command?command:"NULL"); - - myargs.seglist = seglist; - myargs.stack = stack; - myargs.command = command; - myargs.length = length; - myargs.result = -1; - myargs.envp = envp; - - if ((proc = IDOS->CreateNewProcTags( - NP_Entry, __myrc, NP_Child, TRUE, NP_Input, IDOS->Input(), - NP_Output, IDOS->Output(), NP_Error, IDOS->ErrorOutput(), - NP_CloseInput, FALSE, NP_CloseOutput, FALSE, NP_CloseError, - FALSE, NP_CopyVars, FALSE, - - // NP_StackSize, ((struct Process - // *)myargs.parent)->pr_StackSize, - NP_Cli, TRUE, NP_UserData, (int)&myargs, - NP_NotifyOnDeathSigTask, thisTask, TAG_DONE))) - - { - IExec->Wait(SIGF_CHILD); - } - return myargs.result; + struct args myargs; + struct Task *thisTask = IExec->FindTask(0); + struct Process *proc; + + // adebug("%s %ld %s\n",__FUNCTION__,__LINE__,command?command:"NULL"); + + myargs.seglist = seglist; + myargs.stack = stack; + myargs.command = command; + myargs.length = length; + myargs.result = -1; + myargs.envp = envp; + + if ((proc = IDOS->CreateNewProcTags( + NP_Entry, __myrc, NP_Child, TRUE, NP_Input, IDOS->Input(), + NP_Output, IDOS->Output(), NP_Error, IDOS->ErrorOutput(), + NP_CloseInput, FALSE, NP_CloseOutput, FALSE, NP_CloseError, + FALSE, NP_CopyVars, FALSE, + + // NP_StackSize, ((struct Process + // *)myargs.parent)->pr_StackSize, + NP_Cli, TRUE, NP_UserData, (int)&myargs, + NP_NotifyOnDeathSigTask, thisTask, TAG_DONE))) + + { + IExec->Wait(SIGF_CHILD); + } + return myargs.result; } char *mystrdup(const char *s) { - char *result = NULL; - size_t size; + char *result = NULL; + size_t size; - size = strlen(s) + 1; + size = strlen(s) + 1; - if ((result = (char *)IExec->AllocVecTags(size, TAG_DONE))) - { - memmove(result, s, size); - } - return result; + if ((result = (char *)IExec->AllocVecTags(size, TAG_DONE))) + { + memmove(result, s, size); + } + return result; } unsigned int pipenum = 0; int pipe(int filedes[2]) { - char pipe_name[1024]; + char pipe_name[1024]; // adebug("%s %ld \n",__FUNCTION__,__LINE__); #ifdef USE_TEMPFILES - sprintf(pipe_name, "/T/%x.%08lx", pipenum++, IUtility->GetUniqueID()); + sprintf(pipe_name, "/T/%x.%08lx", pipenum++, IUtility->GetUniqueID()); #else - sprintf(pipe_name, "/PIPE/%x%08lx/4096/0", pipenum++, - IUtility->GetUniqueID()); + sprintf(pipe_name, "/PIPE/%x%08lx/4096/0", pipenum++, + IUtility->GetUniqueID()); #endif - /* printf("pipe: %s \n", pipe_name);*/ - - filedes[1] = open(pipe_name, O_WRONLY | O_CREAT); - filedes[0] = open(pipe_name, O_RDONLY); - if (filedes[0] == -1 || filedes[1] == -1) - { - if (filedes[0] != -1) - close(filedes[0]); - if (filedes[1] != -1) - close(filedes[1]); - return -1; - } - /* printf("filedes %d %d\n", filedes[0], - * filedes[1]);fflush(stdout);*/ - - return 0; + /* printf("pipe: %s \n", pipe_name);*/ + + filedes[1] = open(pipe_name, O_WRONLY | O_CREAT); + filedes[0] = open(pipe_name, O_RDONLY); + if (filedes[0] == -1 || filedes[1] == -1) + { + if (filedes[0] != -1) + close(filedes[0]); + if (filedes[1] != -1) + close(filedes[1]); + return -1; + } + /* printf("filedes %d %d\n", filedes[0], + * filedes[1]);fflush(stdout);*/ + + return 0; } int fork(void) { - fprintf(stderr, "Can not bloody fork\n"); - errno = ENOMEM; - return -1; + fprintf(stderr, "Can not bloody fork\n"); + errno = ENOMEM; + return -1; } int wait(__attribute__((unused))int *status) { - fprintf(stderr, "No wait try waitpid instead\n"); - errno = ECHILD; - return -1; + fprintf(stderr, "No wait try waitpid instead\n"); + errno = ECHILD; + return -1; } char *convert_path_a2u(const char *filename) { - struct NameTranslationInfo nti; + struct NameTranslationInfo nti; - if (!filename) - { - return 0; - } + if (!filename) + { + return 0; + } - __translate_amiga_to_unix_path_name(&filename, &nti); + __translate_amiga_to_unix_path_name(&filename, &nti); - return mystrdup(filename); + return mystrdup(filename); } char *convert_path_u2a(const char *filename) { - struct NameTranslationInfo nti; + struct NameTranslationInfo nti; - if (!filename) - { - return 0; - } + if (!filename) + { + return 0; + } - if (strcmp(filename, "/dev/tty") == 0) - { - return mystrdup("CONSOLE:"); - ; - } + if (strcmp(filename, "/dev/tty") == 0) + { + return mystrdup("CONSOLE:"); + ; + } - __translate_unix_to_amiga_path_name(&filename, &nti); + __translate_unix_to_amiga_path_name(&filename, &nti); - return mystrdup(filename); + return mystrdup(filename); } struct SignalSemaphore environ_sema; @@ -246,278 +246,278 @@ struct SignalSemaphore popen_sema; void amigaos4_init_environ_sema() { - IExec->InitSemaphore(&environ_sema); - IExec->InitSemaphore(&popen_sema); + IExec->InitSemaphore(&environ_sema); + IExec->InitSemaphore(&popen_sema); } void amigaos4_obtain_environ() { - IExec->ObtainSemaphore(&environ_sema); + IExec->ObtainSemaphore(&environ_sema); } void amigaos4_release_environ() { - IExec->ReleaseSemaphore(&environ_sema); + IExec->ReleaseSemaphore(&environ_sema); } static void createvars(char **envp) { - if (envp) - { - /* Set a local var to indicate to any subsequent sh that it is - * not - * the top level shell and so should only inherit local amigaos - * vars */ - IDOS->SetVar("ABCSH_IMPORT_LOCAL", "TRUE", 5, GVF_LOCAL_ONLY); - - amigaos4_obtain_environ(); - - envp = myenviron; - - while ((envp != NULL) && (*envp != NULL)) - { - int len; - char *var; - char *val; - if ((len = strlen(*envp))) - { - if ((var = (char *)IExec->AllocVecTags(len + 1, AVT_ClearWithValue,0,TAG_DONE))) - { - strcpy(var, *envp); - - val = strchr(var, '='); - if (val) - { - *val++ = '\0'; - if (*val) - { - IDOS->SetVar( - var, val, - strlen(val) + 1, - GVF_LOCAL_ONLY); - } - } - IExec->FreeVec(var); - } - } - envp++; - } - amigaos4_release_environ(); - } + if (envp) + { + /* Set a local var to indicate to any subsequent sh that it is + * not + * the top level shell and so should only inherit local amigaos + * vars */ + IDOS->SetVar("ABCSH_IMPORT_LOCAL", "TRUE", 5, GVF_LOCAL_ONLY); + + amigaos4_obtain_environ(); + + envp = myenviron; + + while ((envp != NULL) && (*envp != NULL)) + { + int len; + char *var; + char *val; + if ((len = strlen(*envp))) + { + if ((var = (char *)IExec->AllocVecTags(len + 1, AVT_ClearWithValue,0,TAG_DONE))) + { + strcpy(var, *envp); + + val = strchr(var, '='); + if (val) + { + *val++ = '\0'; + if (*val) + { + IDOS->SetVar( + var, val, + strlen(val) + 1, + GVF_LOCAL_ONLY); + } + } + IExec->FreeVec(var); + } + } + envp++; + } + amigaos4_release_environ(); + } } struct command_data { - STRPTR args; - BPTR seglist; - struct Task *parent; + STRPTR args; + BPTR seglist; + struct Task *parent; }; int myexecvp(bool isperlthread, const char *filename, char *argv[]) { - // adebug("%s %ld - //%s\n",__FUNCTION__,__LINE__,filename?filename:"NULL"); - /* if there's a slash or a colon consider filename a path and skip - * search */ - int res; - char *name = NULL; - char *pathpart = NULL; - if ((strchr(filename, '/') == NULL) && (strchr(filename, ':') == NULL)) - { - const char *path; - const char *p; - size_t len; - struct stat st; - - if (!(path = getenv("PATH"))) - { - path = ".:/bin:/usr/bin:/c"; - } - - len = strlen(filename) + 1; - name = (char *)IExec->AllocVecTags(strlen(path) + len, AVT_ClearWithValue,0,AVT_Type,MEMF_SHARED,TAG_DONE); - pathpart = (char *)IExec->AllocVecTags(strlen(path) + 1, AVT_ClearWithValue,0,AVT_Type,MEMF_SHARED,TAG_DONE); - p = path; - do - { - path = p; - - if (!(p = strchr(path, ':'))) - { - p = strchr(path, '\0'); - } - - memcpy(pathpart, path, p - path); - pathpart[p - path] = '\0'; - if (!(strlen(pathpart) == 0)) - { - sprintf(name, "%s/%s", pathpart, filename); - } - else - sprintf(name, "%s", filename); - - if ((stat(name, &st) == 0) && (S_ISREG(st.st_mode))) - { - /* we stated it and it's a regular file */ - /* let's boogie! */ - filename = name; - break; - } - - } - while (*p++ != '\0'); - } - - res = myexecve(isperlthread, filename, argv, myenviron); - - if(name) - { - IExec->FreeVec((APTR)name); - name = NULL; - } - if(pathpart) - { - IExec->FreeVec((APTR)pathpart); - pathpart = NULL; - } - return res; + // adebug("%s %ld + //%s\n",__FUNCTION__,__LINE__,filename?filename:"NULL"); + /* if there's a slash or a colon consider filename a path and skip + * search */ + int res; + char *name = NULL; + char *pathpart = NULL; + if ((strchr(filename, '/') == NULL) && (strchr(filename, ':') == NULL)) + { + const char *path; + const char *p; + size_t len; + struct stat st; + + if (!(path = getenv("PATH"))) + { + path = ".:/bin:/usr/bin:/c"; + } + + len = strlen(filename) + 1; + name = (char *)IExec->AllocVecTags(strlen(path) + len, AVT_ClearWithValue,0,AVT_Type,MEMF_SHARED,TAG_DONE); + pathpart = (char *)IExec->AllocVecTags(strlen(path) + 1, AVT_ClearWithValue,0,AVT_Type,MEMF_SHARED,TAG_DONE); + p = path; + do + { + path = p; + + if (!(p = strchr(path, ':'))) + { + p = strchr(path, '\0'); + } + + memcpy(pathpart, path, p - path); + pathpart[p - path] = '\0'; + if (!(strlen(pathpart) == 0)) + { + sprintf(name, "%s/%s", pathpart, filename); + } + else + sprintf(name, "%s", filename); + + if ((stat(name, &st) == 0) && (S_ISREG(st.st_mode))) + { + /* we stated it and it's a regular file */ + /* let's boogie! */ + filename = name; + break; + } + + } + while (*p++ != '\0'); + } + + res = myexecve(isperlthread, filename, argv, myenviron); + + if(name) + { + IExec->FreeVec((APTR)name); + name = NULL; + } + if(pathpart) + { + IExec->FreeVec((APTR)pathpart); + pathpart = NULL; + } + return res; } int myexecv(bool isperlthread, const char *path, char *argv[]) { - return myexecve(isperlthread, path, argv, myenviron); + return myexecve(isperlthread, path, argv, myenviron); } int myexecl(bool isperlthread, const char *path, ...) { - va_list va; - char *argv[1024]; /* 1024 enough? let's hope so! */ - int i = 0; - // adebug("%s %ld\n",__FUNCTION__,__LINE__); - - va_start(va, path); - i = 0; - - do - { - argv[i] = va_arg(va, char *); - } - while (argv[i++] != NULL); - - va_end(va); - return myexecve(isperlthread, path, argv, myenviron); + va_list va; + char *argv[1024]; /* 1024 enough? let's hope so! */ + int i = 0; + // adebug("%s %ld\n",__FUNCTION__,__LINE__); + + va_start(va, path); + i = 0; + + do + { + argv[i] = va_arg(va, char *); + } + while (argv[i++] != NULL); + + va_end(va); + return myexecve(isperlthread, path, argv, myenviron); } int pause(void) { - fprintf(stderr, "Pause not implemented\n"); + fprintf(stderr, "Pause not implemented\n"); - errno = EINTR; - return -1; + errno = EINTR; + return -1; } uint32 size_env(struct Hook *hook, __attribute__((unused))APTR userdata, struct ScanVarsMsg *message) { - if (strlen(message->sv_GDir) <= 4) - { - hook->h_Data = (APTR)(((uint32)hook->h_Data) + 1); - } - return 0; + if (strlen(message->sv_GDir) <= 4) + { + hook->h_Data = (APTR)(((uint32)hook->h_Data) + 1); + } + return 0; } uint32 copy_env(struct Hook *hook, __attribute__((unused))APTR userdata, struct ScanVarsMsg *message) { - if (strlen(message->sv_GDir) <= 4) - { - char **env = (char **)hook->h_Data; - uint32 size = - strlen(message->sv_Name) + 1 + message->sv_VarLen + 1 + 1; - char *buffer = (char *)IExec->AllocVecTags((uint32)size,AVT_ClearWithValue,0,TAG_DONE); - - - snprintf(buffer, size - 1, "%s=%s", message->sv_Name, - message->sv_Var); - - *env = buffer; - env++; - hook->h_Data = env; - } - return 0; + if (strlen(message->sv_GDir) <= 4) + { + char **env = (char **)hook->h_Data; + uint32 size = + strlen(message->sv_Name) + 1 + message->sv_VarLen + 1 + 1; + char *buffer = (char *)IExec->AllocVecTags((uint32)size,AVT_ClearWithValue,0,TAG_DONE); + + + snprintf(buffer, size - 1, "%s=%s", message->sv_Name, + message->sv_Var); + + *env = buffer; + env++; + hook->h_Data = env; + } + return 0; } void ___makeenviron() { - struct Hook *hook = (struct Hook *)IExec->AllocSysObjectTags(ASOT_HOOK,TAG_DONE); - - if(hook) - { - char varbuf[8]; - uint32 flags = 0; - - struct DOSIFace *myIDOS = - (struct DOSIFace *)OpenInterface("dos.library", 53); - if (myIDOS) - { - uint32 size = 0; - if (myIDOS->GetVar("ABCSH_IMPORT_LOCAL", varbuf, 8, - GVF_LOCAL_ONLY) > 0) - { - flags = GVF_LOCAL_ONLY; - } - else - { - flags = GVF_GLOBAL_ONLY; - } - - hook->h_Entry = size_env; - hook->h_Data = 0; - - myIDOS->ScanVars(hook, flags, 0); - size = ((uint32)hook->h_Data) + 1; - - myenviron = (char **)IExec->AllocVecTags(size * - sizeof(char **), - AVT_ClearWithValue,0,TAG_DONE); - origenviron = myenviron; - if (!myenviron) - { - IExec->FreeSysObject(ASOT_HOOK,hook); - CloseInterface((struct Interface *)myIDOS); - return; - } - hook->h_Entry = copy_env; - hook->h_Data = myenviron; - - myIDOS->ScanVars(hook, flags, 0); - IExec->FreeSysObject(ASOT_HOOK,hook); - CloseInterface((struct Interface *)myIDOS); - } - } + struct Hook *hook = (struct Hook *)IExec->AllocSysObjectTags(ASOT_HOOK,TAG_DONE); + + if(hook) + { + char varbuf[8]; + uint32 flags = 0; + + struct DOSIFace *myIDOS = + (struct DOSIFace *)OpenInterface("dos.library", 53); + if (myIDOS) + { + uint32 size = 0; + if (myIDOS->GetVar("ABCSH_IMPORT_LOCAL", varbuf, 8, + GVF_LOCAL_ONLY) > 0) + { + flags = GVF_LOCAL_ONLY; + } + else + { + flags = GVF_GLOBAL_ONLY; + } + + hook->h_Entry = size_env; + hook->h_Data = 0; + + myIDOS->ScanVars(hook, flags, 0); + size = ((uint32)hook->h_Data) + 1; + + myenviron = (char **)IExec->AllocVecTags(size * + sizeof(char **), + AVT_ClearWithValue,0,TAG_DONE); + origenviron = myenviron; + if (!myenviron) + { + IExec->FreeSysObject(ASOT_HOOK,hook); + CloseInterface((struct Interface *)myIDOS); + return; + } + hook->h_Entry = copy_env; + hook->h_Data = myenviron; + + myIDOS->ScanVars(hook, flags, 0); + IExec->FreeSysObject(ASOT_HOOK,hook); + CloseInterface((struct Interface *)myIDOS); + } + } } void ___freeenviron() { - char **i; - /* perl might change environ, it puts it back except for ctrl-c */ - /* so restore our own copy here */ - struct DOSIFace *myIDOS = - (struct DOSIFace *)OpenInterface("dos.library", 53); - if (myIDOS) - { - myenviron = origenviron; - - if (myenviron) - { - for (i = myenviron; *i != NULL; i++) - { - IExec->FreeVec(*i); - } - IExec->FreeVec(myenviron); - myenviron = NULL; - } - CloseInterface((struct Interface *)myIDOS); - } + char **i; + /* perl might change environ, it puts it back except for ctrl-c */ + /* so restore our own copy here */ + struct DOSIFace *myIDOS = + (struct DOSIFace *)OpenInterface("dos.library", 53); + if (myIDOS) + { + myenviron = origenviron; + + if (myenviron) + { + for (i = myenviron; *i != NULL; i++) + { + IExec->FreeVec(*i); + } + IExec->FreeVec(myenviron); + myenviron = NULL; + } + CloseInterface((struct Interface *)myIDOS); + } } @@ -530,126 +530,126 @@ void ___freeenviron() int afstat(int fd, struct stat *statb) { - int result; - BPTR fh; - int mode; - BOOL input; - /* In the first instance pass it to fstat */ - // adebug("fd %ld ad %ld\n",fd,amigaos_get_file(fd)); + int result; + BPTR fh; + int mode; + BOOL input; + /* In the first instance pass it to fstat */ + // adebug("fd %ld ad %ld\n",fd,amigaos_get_file(fd)); - if ((result = fstat(fd, statb) >= 0)) - return result; + if ((result = fstat(fd, statb) >= 0)) + return result; - /* Now we've got a file descriptor but we failed to stat it */ - /* Could be a nil: or could be a std#? */ + /* Now we've got a file descriptor but we failed to stat it */ + /* Could be a nil: or could be a std#? */ - /* if get_default_file fails we had a dud fd so return failure */ + /* if get_default_file fails we had a dud fd so return failure */ #if !defined(__CLIB2__) - fh = amigaos_get_file(fd); - - /* if nil: return failure*/ - if (fh == 0) - return -1; - - /* Now compare with our process Input() Output() etc */ - /* if these were regular files sockets or pipes we had already - * succeeded */ - /* so we can guess they a character special console.... I hope */ - - struct ExamineData *data; - char name[120]; - name[0] = '\0'; - - data = IDOS->ExamineObjectTags(EX_FileHandleInput, fh, TAG_END); - if (data != NULL) - { - - IUtility->Strlcpy(name, data->Name, sizeof(name)); - - IDOS->FreeDosObject(DOS_EXAMINEDATA, data); - } - - // adebug("ad %ld '%s'\n",amigaos_get_file(fd),name); - mode = S_IFCHR; - - if (fh == IDOS->Input()) - { - input = TRUE; - SET_FLAG(mode, S_IRUSR); - SET_FLAG(mode, S_IRGRP); - SET_FLAG(mode, S_IROTH); - } - else if (fh == IDOS->Output() || fh == IDOS->ErrorOutput()) - { - input = FALSE; - SET_FLAG(mode, S_IWUSR); - SET_FLAG(mode, S_IWGRP); - SET_FLAG(mode, S_IWOTH); - } - else - { - /* we got a filehandle not handle by fstat or the above */ - /* most likely it's NIL: but lets check */ - struct ExamineData *exd = NULL; - if ((exd = IDOS->ExamineObjectTags(EX_FileHandleInput, fh, - TAG_DONE))) - { - BOOL isnil = FALSE; - if (exd->Type == - (20060920)) // Ugh yes I know nasty..... - { - isnil = TRUE; - } - IDOS->FreeDosObject(DOS_EXAMINEDATA, exd); - if (isnil) - { - /* yep we got NIL: */ - SET_FLAG(mode, S_IRUSR); - SET_FLAG(mode, S_IRGRP); - SET_FLAG(mode, S_IROTH); - SET_FLAG(mode, S_IWUSR); - SET_FLAG(mode, S_IWGRP); - SET_FLAG(mode, S_IWOTH); - } - else - { - IExec->DebugPrintF( - "unhandled filehandle in afstat()\n"); - return -1; - } - } - } - - memset(statb, 0, sizeof(statb)); - - statb->st_mode = mode; + fh = amigaos_get_file(fd); + + /* if nil: return failure*/ + if (fh == 0) + return -1; + + /* Now compare with our process Input() Output() etc */ + /* if these were regular files sockets or pipes we had already + * succeeded */ + /* so we can guess they a character special console.... I hope */ + + struct ExamineData *data; + char name[120]; + name[0] = '\0'; + + data = IDOS->ExamineObjectTags(EX_FileHandleInput, fh, TAG_END); + if (data != NULL) + { + + IUtility->Strlcpy(name, data->Name, sizeof(name)); + + IDOS->FreeDosObject(DOS_EXAMINEDATA, data); + } + + // adebug("ad %ld '%s'\n",amigaos_get_file(fd),name); + mode = S_IFCHR; + + if (fh == IDOS->Input()) + { + input = TRUE; + SET_FLAG(mode, S_IRUSR); + SET_FLAG(mode, S_IRGRP); + SET_FLAG(mode, S_IROTH); + } + else if (fh == IDOS->Output() || fh == IDOS->ErrorOutput()) + { + input = FALSE; + SET_FLAG(mode, S_IWUSR); + SET_FLAG(mode, S_IWGRP); + SET_FLAG(mode, S_IWOTH); + } + else + { + /* we got a filehandle not handle by fstat or the above */ + /* most likely it's NIL: but lets check */ + struct ExamineData *exd = NULL; + if ((exd = IDOS->ExamineObjectTags(EX_FileHandleInput, fh, + TAG_DONE))) + { + BOOL isnil = FALSE; + if (exd->Type == + (20060920)) // Ugh yes I know nasty..... + { + isnil = TRUE; + } + IDOS->FreeDosObject(DOS_EXAMINEDATA, exd); + if (isnil) + { + /* yep we got NIL: */ + SET_FLAG(mode, S_IRUSR); + SET_FLAG(mode, S_IRGRP); + SET_FLAG(mode, S_IROTH); + SET_FLAG(mode, S_IWUSR); + SET_FLAG(mode, S_IWGRP); + SET_FLAG(mode, S_IWOTH); + } + else + { + IExec->DebugPrintF( + "unhandled filehandle in afstat()\n"); + return -1; + } + } + } + + memset(statb, 0, sizeof(statb)); + + statb->st_mode = mode; #endif - return 0; + return 0; } BPTR amigaos_get_file(int fd) { - BPTR fh = (BPTR)NULL; - if (!(fh = _get_osfhandle(fd))) - { - switch (fd) - { - case 0: - fh = IDOS->Input(); - break; - case 1: - fh = IDOS->Output(); - break; - case 2: - fh = IDOS->ErrorOutput(); - break; - default: - break; - } - } - return fh; + BPTR fh = (BPTR)NULL; + if (!(fh = _get_osfhandle(fd))) + { + switch (fd) + { + case 0: + fh = IDOS->Input(); + break; + case 1: + fh = IDOS->Output(); + break; + case 2: + fh = IDOS->ErrorOutput(); + break; + default: + break; + } + } + return fh; } /*########################################################################*/ @@ -662,78 +662,78 @@ BPTR amigaos_get_file(int fd) int amigaos_flock(int fd, int oper) { - BPTR fh; - int32 success = -1; - - if (!(fh = amigaos_get_file(fd))) - { - errno = EBADF; - return -1; - } - - switch (oper) - { - case LOCK_SH: - { - if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, - REC_SHARED | RECF_DOS_METHOD_ONLY, - TIMEOUT)) - { - success = 0; - } - break; - } - case LOCK_EX: - { - if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, - REC_EXCLUSIVE | RECF_DOS_METHOD_ONLY, - TIMEOUT)) - { - success = 0; - } - break; - } - case LOCK_SH | LOCK_NB: - { - if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, - REC_SHARED_IMMED | RECF_DOS_METHOD_ONLY, - TIMEOUT)) - { - success = 0; - } - else - { - errno = EWOULDBLOCK; - } - break; - } - case LOCK_EX | LOCK_NB: - { - if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, - REC_EXCLUSIVE_IMMED | RECF_DOS_METHOD_ONLY, - TIMEOUT)) - { - success = 0; - } - else - { - errno = EWOULDBLOCK; - } - break; - } - case LOCK_UN: - { - if (IDOS->UnLockRecord(fh, LOCK_START, LOCK_LENGTH)) - { - success = 0; - } - break; - } - default: - { - errno = EINVAL; - return -1; - } - } - return success; + BPTR fh; + int32 success = -1; + + if (!(fh = amigaos_get_file(fd))) + { + errno = EBADF; + return -1; + } + + switch (oper) + { + case LOCK_SH: + { + if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, + REC_SHARED | RECF_DOS_METHOD_ONLY, + TIMEOUT)) + { + success = 0; + } + break; + } + case LOCK_EX: + { + if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, + REC_EXCLUSIVE | RECF_DOS_METHOD_ONLY, + TIMEOUT)) + { + success = 0; + } + break; + } + case LOCK_SH | LOCK_NB: + { + if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, + REC_SHARED_IMMED | RECF_DOS_METHOD_ONLY, + TIMEOUT)) + { + success = 0; + } + else + { + errno = EWOULDBLOCK; + } + break; + } + case LOCK_EX | LOCK_NB: + { + if (IDOS->LockRecord(fh, LOCK_START, LOCK_LENGTH, + REC_EXCLUSIVE_IMMED | RECF_DOS_METHOD_ONLY, + TIMEOUT)) + { + success = 0; + } + else + { + errno = EWOULDBLOCK; + } + break; + } + case LOCK_UN: + { + if (IDOS->UnLockRecord(fh, LOCK_START, LOCK_LENGTH)) + { + success = 0; + } + break; + } + default: + { + errno = EINVAL; + return -1; + } + } + return success; } @@ -28,22 +28,22 @@ Perl_av_reify(pTHX_ AV *av) assert(SvTYPE(av) == SVt_PVAV); if (AvREAL(av)) - return; + return; #ifdef DEBUGGING if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array"); #endif key = AvMAX(av) + 1; while (key > AvFILLp(av) + 1) - AvARRAY(av)[--key] = NULL; + AvARRAY(av)[--key] = NULL; while (key) { - SV * const sv = AvARRAY(av)[--key]; - if (sv != &PL_sv_undef) - SvREFCNT_inc_simple_void(sv); + SV * const sv = AvARRAY(av)[--key]; + if (sv != &PL_sv_undef) + SvREFCNT_inc_simple_void(sv); } key = AvARRAY(av) - AvALLOC(av); while (key) - AvALLOC(av)[--key] = NULL; + AvALLOC(av)[--key] = NULL; AvREIFY_off(av); AvREAL_on(av); } @@ -72,7 +72,7 @@ Perl_av_extend(pTHX_ AV *av, SSize_t key) mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied); if (mg) { - SV *arg1 = sv_newmortal(); + SV *arg1 = sv_newmortal(); /* NOTE: the API for av_extend() is NOT the same as the tie method EXTEND. * * The C function takes an *index* (assumes 0 indexed arrays) and ensures @@ -82,10 +82,10 @@ Perl_av_extend(pTHX_ AV *av, SSize_t key) * is at least that many elements large. Thus we have to +1 the key when * we call the tied method. */ - sv_setiv(arg1, (IV)(key + 1)); - Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1, - arg1); - return; + sv_setiv(arg1, (IV)(key + 1)); + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1, + arg1); + return; } av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av)); } @@ -225,23 +225,23 @@ S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp) { bool adjust_index = 1; if (mg) { - /* Handle negative array indices 20020222 MJD */ - SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg); - SvGETMAGIC(ref); - if (SvROK(ref) && SvOBJECT(SvRV(ref))) { - SV * const * const negative_indices_glob = - hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0); - - if (negative_indices_glob && isGV(*negative_indices_glob) - && SvTRUE(GvSV(*negative_indices_glob))) - adjust_index = 0; - } + /* Handle negative array indices 20020222 MJD */ + SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg); + SvGETMAGIC(ref); + if (SvROK(ref) && SvOBJECT(SvRV(ref))) { + SV * const * const negative_indices_glob = + hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0); + + if (negative_indices_glob && isGV(*negative_indices_glob) + && SvTRUE(GvSV(*negative_indices_glob))) + adjust_index = 0; + } } if (adjust_index) { - *keyp += AvFILL(av) + 1; - if (*keyp < 0) - return FALSE; + *keyp += AvFILL(av) + 1; + if (*keyp < 0) + return FALSE; } return TRUE; } @@ -257,22 +257,22 @@ Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) if (UNLIKELY(SvRMAGICAL(av))) { const MAGIC * const tied_magic - = mg_find((const SV *)av, PERL_MAGIC_tied); + = mg_find((const SV *)av, PERL_MAGIC_tied); if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) { - SV *sv; - if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) - return NULL; - } + SV *sv; + if (key < 0) { + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + return NULL; + } sv = sv_newmortal(); - sv_upgrade(sv, SVt_PVLV); - mg_copy(MUTABLE_SV(av), sv, 0, key); - if (!tied_magic) /* for regdata, force leavesub to make copies */ - SvTEMP_off(sv); - LvTYPE(sv) = 't'; - LvTARG(sv) = sv; /* fake (SV**) */ - return &(LvTARG(sv)); + sv_upgrade(sv, SVt_PVLV); + mg_copy(MUTABLE_SV(av), sv, 0, key); + if (!tied_magic) /* for regdata, force leavesub to make copies */ + SvTEMP_off(sv); + LvTYPE(sv) = 't'; + LvTARG(sv) = sv; /* fake (SV**) */ + return &(LvTARG(sv)); } } @@ -283,14 +283,14 @@ Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size) * to be tested as a single condition */ if ((Size_t)key >= (Size_t)size) { - if (UNLIKELY(neg)) - return NULL; + if (UNLIKELY(neg)) + return NULL; goto emptyness; } if (!AvARRAY(av)[key]) { emptyness: - return lval ? av_store(av,key,newSV(0)) : NULL; + return lval ? av_store(av,key,newSV(0)) : NULL; } return &AvARRAY(av)[key]; @@ -334,59 +334,59 @@ Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val) const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); if (tied_magic) { if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return 0; } - if (val) { - mg_copy(MUTABLE_SV(av), val, 0, key); - } - return NULL; + if (val) { + mg_copy(MUTABLE_SV(av), val, 0, key); + } + return NULL; } } if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return NULL; + key += AvFILL(av) + 1; + if (key < 0) + return NULL; } if (SvREADONLY(av) && key >= AvFILL(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if (!AvREAL(av) && AvREIFY(av)) - av_reify(av); + av_reify(av); if (key > AvMAX(av)) - av_extend(av,key); + av_extend(av,key); ary = AvARRAY(av); if (AvFILLp(av) < key) { - if (!AvREAL(av)) { - if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) - PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ - do { - ary[++AvFILLp(av)] = NULL; - } while (AvFILLp(av) < key); - } - AvFILLp(av) = key; + if (!AvREAL(av)) { + if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) + PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ + do { + ary[++AvFILLp(av)] = NULL; + } while (AvFILLp(av) < key); + } + AvFILLp(av) = key; } else if (AvREAL(av)) - SvREFCNT_dec(ary[key]); + SvREFCNT_dec(ary[key]); ary[key] = val; if (SvSMAGICAL(av)) { - const MAGIC *mg = SvMAGIC(av); - bool set = TRUE; - for (; mg; mg = mg->mg_moremagic) { - if (!isUPPER(mg->mg_type)) continue; - if (val) { - sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key); - } - if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) { - PL_delaymagic |= DM_ARRAY_ISA; - set = FALSE; - } - } - if (set) - mg_set(MUTABLE_SV(av)); + const MAGIC *mg = SvMAGIC(av); + bool set = TRUE; + for (; mg; mg = mg->mg_moremagic) { + if (!isUPPER(mg->mg_type)) continue; + if (val) { + sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key); + } + if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) { + PL_delaymagic |= DM_ARRAY_ISA; + set = FALSE; + } + } + if (set) + mg_set(MUTABLE_SV(av)); } return &ary[key]; } @@ -416,29 +416,29 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp) SSize_t i; SSize_t orig_ix; - Newx(ary,size,SV*); - AvALLOC(av) = ary; - AvARRAY(av) = ary; - AvMAX(av) = size - 1; + Newx(ary,size,SV*); + AvALLOC(av) = ary; + AvARRAY(av) = ary; + AvMAX(av) = size - 1; /* avoid av being leaked if croak when calling magic below */ EXTEND_MORTAL(1); PL_tmps_stack[++PL_tmps_ix] = (SV*)av; orig_ix = PL_tmps_ix; - for (i = 0; i < size; i++) { - assert (*strp); + for (i = 0; i < size; i++) { + assert (*strp); - /* Don't let sv_setsv swipe, since our source array might - have multiple references to the same temp scalar (e.g. - from a list slice) */ + /* Don't let sv_setsv swipe, since our source array might + have multiple references to the same temp scalar (e.g. + from a list slice) */ - SvGETMAGIC(*strp); /* before newSV, in case it dies */ - AvFILLp(av)++; - ary[i] = newSV(0); - sv_setsv_flags(ary[i], *strp, - SV_DO_COW_SVSETSV|SV_NOSTEAL); - strp++; - } + SvGETMAGIC(*strp); /* before newSV, in case it dies */ + AvFILLp(av)++; + ary[i] = newSV(0); + sv_setsv_flags(ary[i], *strp, + SV_DO_COW_SVSETSV|SV_NOSTEAL); + strp++; + } /* disarm av's leak guard */ if (LIKELY(PL_tmps_ix == orig_ix)) PL_tmps_ix--; @@ -476,46 +476,46 @@ Perl_av_clear(pTHX_ AV *av) #ifdef DEBUGGING if (SvREFCNT(av) == 0) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); } #endif if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); /* Give any tie a chance to cleanup first */ if (SvRMAGICAL(av)) { - const MAGIC* const mg = SvMAGIC(av); - if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa) - PL_delaymagic |= DM_ARRAY_ISA; + const MAGIC* const mg = SvMAGIC(av); + if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa) + PL_delaymagic |= DM_ARRAY_ISA; else - mg_clear(MUTABLE_SV(av)); + mg_clear(MUTABLE_SV(av)); } if (AvMAX(av) < 0) - return; + return; if ((real = cBOOL(AvREAL(av)))) { - SV** const ary = AvARRAY(av); - SSize_t index = AvFILLp(av) + 1; + SV** const ary = AvARRAY(av); + SSize_t index = AvFILLp(av) + 1; /* avoid av being freed when calling destructors below */ EXTEND_MORTAL(1); PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); orig_ix = PL_tmps_ix; - while (index) { - SV * const sv = ary[--index]; - /* undef the slot before freeing the value, because a - * destructor might try to modify this array */ - ary[index] = NULL; - SvREFCNT_dec(sv); - } + while (index) { + SV * const sv = ary[--index]; + /* undef the slot before freeing the value, because a + * destructor might try to modify this array */ + ary[index] = NULL; + SvREFCNT_dec(sv); + } } extra = AvARRAY(av) - AvALLOC(av); if (extra) { - AvMAX(av) += extra; - AvARRAY(av) = AvALLOC(av); + AvMAX(av) += extra; + AvARRAY(av) = AvALLOC(av); } AvFILLp(av) = -1; if (real) { @@ -553,19 +553,19 @@ Perl_av_undef(pTHX_ AV *av) /* Give any tie a chance to cleanup first */ if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) - av_fill(av, -1); + av_fill(av, -1); real = cBOOL(AvREAL(av)); if (real) { - SSize_t key = AvFILLp(av) + 1; + SSize_t key = AvFILLp(av) + 1; /* avoid av being freed when calling destructors below */ EXTEND_MORTAL(1); PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); orig_ix = PL_tmps_ix; - while (key) - SvREFCNT_dec(AvARRAY(av)[--key]); + while (key) + SvREFCNT_dec(AvARRAY(av)[--key]); } Safefree(AvALLOC(av)); @@ -600,7 +600,7 @@ Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val) PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH; if (!*avp) - *avp = newAV(); + *avp = newAV(); av_push(*avp, val); } @@ -624,12 +624,12 @@ Perl_av_push(pTHX_ AV *av, SV *val) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1, - val); - return; + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1, + val); + return; } av_store(av,AvFILLp(av)+1,val); } @@ -656,19 +656,19 @@ Perl_av_pop(pTHX_ AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0); - if (retval) - retval = newSVsv(retval); - return retval; + retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0); + if (retval) + retval = newSVsv(retval); + return retval; } if (AvFILL(av) < 0) - return &PL_sv_undef; + return &PL_sv_undef; retval = AvARRAY(av)[AvFILLp(av)]; AvARRAY(av)[AvFILLp(av)--] = NULL; if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); + mg_set(MUTABLE_SV(av)); return retval ? retval : &PL_sv_undef; } @@ -689,7 +689,7 @@ Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val) PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE; if (!*avp) - *avp = newAV(); + *avp = newAV(); av_unshift(*avp, 1); return av_store(*avp, 0, val); } @@ -715,45 +715,45 @@ Perl_av_unshift(pTHX_ AV *av, SSize_t num) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT), - G_DISCARD | G_UNDEF_FILL, num); - return; + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT), + G_DISCARD | G_UNDEF_FILL, num); + return; } if (num <= 0) return; if (!AvREAL(av) && AvREIFY(av)) - av_reify(av); + av_reify(av); i = AvARRAY(av) - AvALLOC(av); if (i) { - if (i > num) - i = num; - num -= i; + if (i > num) + i = num; + num -= i; - AvMAX(av) += i; - AvFILLp(av) += i; - AvARRAY(av) = AvARRAY(av) - i; + AvMAX(av) += i; + AvFILLp(av) += i; + AvARRAY(av) = AvARRAY(av) - i; } if (num) { - SV **ary; - const SSize_t i = AvFILLp(av); - /* Create extra elements */ - const SSize_t slide = i > 0 ? i : 0; - num += slide; - av_extend(av, i + num); - AvFILLp(av) += num; - ary = AvARRAY(av); - Move(ary, ary + num, i + 1, SV*); - do { - ary[--num] = NULL; - } while (num); - /* Make extra elements into a buffer */ - AvMAX(av) -= slide; - AvFILLp(av) -= slide; - AvARRAY(av) = AvARRAY(av) + slide; + SV **ary; + const SSize_t i = AvFILLp(av); + /* Create extra elements */ + const SSize_t slide = i > 0 ? i : 0; + num += slide; + av_extend(av, i + num); + AvFILLp(av) += num; + ary = AvARRAY(av); + Move(ary, ary + num, i + 1, SV*); + do { + ary[--num] = NULL; + } while (num); + /* Make extra elements into a buffer */ + AvMAX(av) -= slide; + AvFILLp(av) -= slide; + AvARRAY(av) = AvARRAY(av) + slide; } } @@ -779,23 +779,23 @@ Perl_av_shift(pTHX_ AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0); - if (retval) - retval = newSVsv(retval); - return retval; + retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0); + if (retval) + retval = newSVsv(retval); + return retval; } if (AvFILL(av) < 0) return &PL_sv_undef; retval = *AvARRAY(av); if (AvREAL(av)) - *AvARRAY(av) = NULL; + *AvARRAY(av) = NULL; AvARRAY(av) = AvARRAY(av) + 1; AvMAX(av)--; AvFILLp(av)--; if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); + mg_set(MUTABLE_SV(av)); return retval ? retval : &PL_sv_undef; } @@ -856,35 +856,35 @@ Perl_av_fill(pTHX_ AV *av, SSize_t fill) assert(SvTYPE(av) == SVt_PVAV); if (fill < 0) - fill = -1; + fill = -1; if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - SV *arg1 = sv_newmortal(); - sv_setiv(arg1, (IV)(fill + 1)); - Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD, - 1, arg1); - return; + SV *arg1 = sv_newmortal(); + sv_setiv(arg1, (IV)(fill + 1)); + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD, + 1, arg1); + return; } if (fill <= AvMAX(av)) { - SSize_t key = AvFILLp(av); - SV** const ary = AvARRAY(av); - - if (AvREAL(av)) { - while (key > fill) { - SvREFCNT_dec(ary[key]); - ary[key--] = NULL; - } - } - else { - while (key < fill) - ary[++key] = NULL; - } - - AvFILLp(av) = fill; - if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); + SSize_t key = AvFILLp(av); + SV** const ary = AvARRAY(av); + + if (AvREAL(av)) { + while (key > fill) { + SvREFCNT_dec(ary[key]); + ary[key--] = NULL; + } + } + else { + while (key < fill) + ary[++key] = NULL; + } + + AvFILLp(av) = fill; + if (SvSMAGICAL(av)) + mg_set(MUTABLE_SV(av)); } else - (void)av_store(av,fill,NULL); + (void)av_store(av,fill,NULL); } /* @@ -909,16 +909,16 @@ Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if (SvRMAGICAL(av)) { const MAGIC * const tied_magic - = mg_find((const SV *)av, PERL_MAGIC_tied); + = mg_find((const SV *)av, PERL_MAGIC_tied); if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) { SV **svp; if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) - return NULL; + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + return NULL; } svp = av_fetch(av, key, TRUE); if (svp) { @@ -928,39 +928,39 @@ Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags) sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */ return sv; } - return NULL; + return NULL; } } } if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return NULL; + key += AvFILL(av) + 1; + if (key < 0) + return NULL; } if (key > AvFILLp(av)) - return NULL; + return NULL; else { - if (!AvREAL(av) && AvREIFY(av)) - av_reify(av); - sv = AvARRAY(av)[key]; - AvARRAY(av)[key] = NULL; - if (key == AvFILLp(av)) { - do { - AvFILLp(av)--; - } while (--key >= 0 && !AvARRAY(av)[key]); - } - if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); + if (!AvREAL(av) && AvREIFY(av)) + av_reify(av); + sv = AvARRAY(av)[key]; + AvARRAY(av)[key] = NULL; + if (key == AvFILLp(av)) { + do { + AvFILLp(av)--; + } while (--key >= 0 && !AvARRAY(av)[key]); + } + if (SvSMAGICAL(av)) + mg_set(MUTABLE_SV(av)); } if(sv != NULL) { - if (flags & G_DISCARD) { - SvREFCNT_dec_NN(sv); - return NULL; - } - else if (AvREAL(av)) - sv_2mortal(sv); + if (flags & G_DISCARD) { + SvREFCNT_dec_NN(sv); + return NULL; + } + else if (AvREAL(av)) + sv_2mortal(sv); } return sv; } @@ -985,14 +985,14 @@ Perl_av_exists(pTHX_ AV *av, SSize_t key) if (SvRMAGICAL(av)) { const MAGIC * const tied_magic - = mg_find((const SV *)av, PERL_MAGIC_tied); + = mg_find((const SV *)av, PERL_MAGIC_tied); const MAGIC * const regdata_magic = mg_find((const SV *)av, PERL_MAGIC_regdata); if (tied_magic || regdata_magic) { MAGIC *mg; /* Handle negative array indices 20020222 MJD */ if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return FALSE; } @@ -1002,36 +1002,36 @@ Perl_av_exists(pTHX_ AV *av, SSize_t key) else return FALSE; } - { - SV * const sv = sv_newmortal(); - mg_copy(MUTABLE_SV(av), sv, 0, key); - mg = mg_find(sv, PERL_MAGIC_tiedelem); - if (mg) { - magic_existspack(sv, mg); - { - I32 retbool = SvTRUE_nomg_NN(sv); - return cBOOL(retbool); - } - } - } + { + SV * const sv = sv_newmortal(); + mg_copy(MUTABLE_SV(av), sv, 0, key); + mg = mg_find(sv, PERL_MAGIC_tiedelem); + if (mg) { + magic_existspack(sv, mg); + { + I32 retbool = SvTRUE_nomg_NN(sv); + return cBOOL(retbool); + } + } + } } } if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return FALSE; + key += AvFILL(av) + 1; + if (key < 0) + return FALSE; } if (key <= AvFILLp(av) && AvARRAY(av)[key]) { - if (SvSMAGICAL(AvARRAY(av)[key]) - && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem)) - return FALSE; - return TRUE; + if (SvSMAGICAL(AvARRAY(av)[key]) + && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem)) + return FALSE; + return TRUE; } else - return FALSE; + return FALSE; } static MAGIC * @@ -1044,11 +1044,11 @@ S_get_aux_mg(pTHX_ AV *av) { mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p); if (!mg) { - mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p, - &PL_vtbl_arylen_p, 0, 0); - assert(mg); - /* sv_magicext won't set this for us because we pass in a NULL obj */ - mg->mg_flags |= MGf_REFCOUNTED; + mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p, + &PL_vtbl_arylen_p, 0, 0); + assert(mg); + /* sv_magicext won't set this for us because we pass in a NULL obj */ + mg->mg_flags |= MGf_REFCOUNTED; } return mg; } @@ -1071,15 +1071,15 @@ Perl_av_iter_p(pTHX_ AV *av) { assert(SvTYPE(av) == SVt_PVAV); if (sizeof(IV) == sizeof(SSize_t)) { - return (IV *)&(mg->mg_len); + return (IV *)&(mg->mg_len); } else { - if (!mg->mg_ptr) { - IV *temp; - mg->mg_len = IVSIZE; - Newxz(temp, 1, IV); - mg->mg_ptr = (char *) temp; - } - return (IV *)mg->mg_ptr; + if (!mg->mg_ptr) { + IV *temp; + mg->mg_len = IVSIZE; + Newxz(temp, 1, IV); + mg->mg_ptr = (char *) temp; + } + return (IV *)mg->mg_ptr; } } @@ -1088,7 +1088,7 @@ Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) { SV * const sv = newSV(0); PERL_ARGS_ASSERT_AV_NONELEM; if (!av_store(av,ix,sv)) - return sv_2mortal(sv); /* has tie magic */ + return sv_2mortal(sv); /* has tie magic */ sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0); return sv; } @@ -83,7 +83,7 @@ If all you need is to look up an array element, then prefer C<av_fetch>. #define AvREALISH(av) (SvFLAGS(av) & (SVpav_REAL|SVpav_REIFY)) #define AvFILL(av) ((SvRMAGICAL((const SV *) (av))) \ - ? mg_size(MUTABLE_SV(av)) : AvFILLp(av)) + ? mg_size(MUTABLE_SV(av)) : AvFILLp(av)) #define av_top_index(av) AvFILL(av) #define av_tindex(av) av_top_index(av) @@ -63,7 +63,7 @@ See L<perlguts/Autoloading with XSUBs>. /* these CvPADLIST/CvRESERVED asserts can be reverted one day, once stabilized */ #define CvPADLIST(sv) (*(assert_(!CvISXSUB((CV*)(sv))) \ - &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_padlist))) + &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_padlist))) /* CvPADLIST_set is not public API, it can be removed one day, once stabilized */ #ifdef DEBUGGING # define CvPADLIST_set(sv, padlist) Perl_set_padlist((CV*)sv, padlist) @@ -71,7 +71,7 @@ See L<perlguts/Autoloading with XSUBs>. # define CvPADLIST_set(sv, padlist) (CvPADLIST(sv) = (padlist)) #endif #define CvHSCXT(sv) *(assert_(CvISXSUB((CV*)(sv))) \ - &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_hscxt)) + &(((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_padlist_u.xcv_hscxt)) #ifdef DEBUGGING # if PTRSIZE == 8 # define PoisonPADLIST(sv) \ @@ -92,20 +92,20 @@ See L<perlguts/Autoloading with XSUBs>. /* These two are sometimes called on non-CVs */ #define CvPROTO(sv) \ - ( \ - SvPOK(sv) \ - ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \ - ? SvEND(sv)+1 : SvPVX_const(sv) \ - : NULL \ - ) + ( \ + SvPOK(sv) \ + ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \ + ? SvEND(sv)+1 : SvPVX_const(sv) \ + : NULL \ + ) #define CvPROTOLEN(sv) \ - ( \ - SvPOK(sv) \ - ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \ - ? SvLEN(sv)-SvCUR(sv)-2 \ - : SvCUR(sv) \ - : 0 \ - ) + ( \ + SvPOK(sv) \ + ? SvTYPE(sv) == SVt_PVCV && CvAUTOLOAD(sv) \ + ? SvLEN(sv)-SvCUR(sv)-2 \ + : SvCUR(sv) \ + : 0 \ + ) #define CVf_METHOD 0x0001 /* CV is explicitly marked as a method */ #define CVf_LVALUE 0x0002 /* CV return value can be used as lvalue */ @@ -117,9 +117,9 @@ See L<perlguts/Autoloading with XSUBs>. #define CVf_CLONED 0x0040 /* a clone of one of those */ #define CVf_ANON 0x0080 /* CV is not pointed to by a GV */ #define CVf_UNIQUE 0x0100 /* sub is only called once (eg PL_main_cv, - * require, eval). */ + * require, eval). */ #define CVf_NODEBUG 0x0200 /* no DB::sub indirection for this CV - (esp. useful for special XSUBs) */ + (esp. useful for special XSUBs) */ #define CVf_CVGV_RC 0x0400 /* CvGV is reference counted */ #if defined(PERL_CORE) || defined(PERL_EXT) # define CVf_SLABBED 0x0800 /* Holds refcount on op slab */ @@ -226,8 +226,8 @@ PERL_STATIC_INLINE HEK * CvNAME_HEK(CV *sv) { return CvNAMED(sv) - ? ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_hek - : 0; + ? ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_hek + : 0; } /* helper for the common pattern: @@ -242,11 +242,11 @@ CvNAME_HEK(CV *sv) /* This lowers the reference count of the previous value, but does *not* increment the reference count of the new value. */ #define CvNAME_HEK_set(cv, hek) ( \ - CvNAME_HEK((CV *)(cv)) \ - ? unshare_hek(SvANY((CV *)(cv))->xcv_gv_u.xcv_hek) \ - : (void)0, \ - ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_gv_u.xcv_hek = (hek), \ - CvNAMED_on(cv) \ + CvNAME_HEK((CV *)(cv)) \ + ? unshare_hek(SvANY((CV *)(cv))->xcv_gv_u.xcv_hek) \ + : (void)0, \ + ((XPVCV*)MUTABLE_PTR(SvANY(cv)))->xcv_gv_u.xcv_hek = (hek), \ + CvNAMED_on(cv) \ ) /* diff --git a/cygwin/cygwin.c b/cygwin/cygwin.c index bbb3e1a829..53b04c67e6 100644 --- a/cygwin/cygwin.c +++ b/cygwin/cygwin.c @@ -35,16 +35,16 @@ do_spawnvp (const char *path, const char * const *argv) rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand); childpid = spawnvp(_P_NOWAIT,path,argv); if (childpid < 0) { - status = -1; - if(ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn \"%s\": %s", - path,Strerror (errno)); + status = -1; + if(ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn \"%s\": %s", + path,Strerror (errno)); } else { - do { - result = wait4pid(childpid, &status, 0); - } while (result == -1 && errno == EINTR); - if(result < 0) - status = -1; + do { + result = wait4pid(childpid, &status, 0); + } while (result == -1 && errno == EINTR); + if(result < 0) + status = -1; } (void)rsignal_restore(SIGINT, &ihand); (void)rsignal_restore(SIGQUIT, &qhand); @@ -98,7 +98,7 @@ do_spawn (char *cmd) ENTER; while (*cmd && isSPACE(*cmd)) - cmd++; + cmd++; if (strBEGINs (cmd,"/bin/sh") && isSPACE (cmd[7])) cmd+=5; @@ -106,32 +106,32 @@ do_spawn (char *cmd) /* save an extra exec if possible */ /* see if there are shell metacharacters in it */ if (strstr (cmd,"...")) - goto doshell; + goto doshell; if (*cmd=='.' && isSPACE (cmd[1])) - goto doshell; + goto doshell; if (strBEGINs (cmd,"exec") && isSPACE (cmd[4])) - goto doshell; + goto doshell; for (s=cmd; *s && isALPHA (*s); s++) ; /* catch VAR=val gizmo */ if (*s=='=') goto doshell; for (s=cmd; *s; s++) - if (strchr (metachars,*s)) - { - if (*s=='\n' && s[1]=='\0') - { - *s='\0'; - break; - } - doshell: - command[0] = "sh"; - command[1] = "-c"; - command[2] = cmd; - command[3] = NULL; - - result = do_spawnvp("sh",command); - goto leave; - } + if (strchr (metachars,*s)) + { + if (*s=='\n' && s[1]=='\0') + { + *s='\0'; + break; + } + doshell: + command[0] = "sh"; + command[1] = "-c"; + command[2] = cmd; + command[3] = NULL; + + result = do_spawnvp("sh",command); + goto leave; + } Newx (argv, (s-cmd)/2+2, const char*); SAVEFREEPV(argv); @@ -139,18 +139,18 @@ do_spawn (char *cmd) SAVEFREEPV(cmd); a=argv; for (s=cmd; *s;) { - while (*s && isSPACE (*s)) s++; - if (*s) - *(a++)=s; - while (*s && !isSPACE (*s)) s++; - if (*s) - *s++='\0'; + while (*s && isSPACE (*s)) s++; + if (*s) + *(a++)=s; + while (*s && !isSPACE (*s)) s++; + if (*s) + *s++='\0'; } *a = (char*)NULL; if (!argv[0]) result = -1; else - result = do_spawnvp(argv[0],(const char * const *)argv); + result = do_spawnvp(argv[0],(const char * const *)argv); leave: LEAVE; return result; @@ -221,12 +221,12 @@ XS(Cygwin_cwd) There is Cwd->cwd() usage in the wild, and previous versions didn't die. */ if(items > 1) - Perl_croak(aTHX_ "Usage: Cwd::cwd()"); + Perl_croak(aTHX_ "Usage: Cwd::cwd()"); if((cwd = getcwd(NULL, -1))) { - ST(0) = sv_2mortal(newSVpv(cwd, 0)); - free(cwd); - SvTAINTED_on(ST(0)); - XSRETURN(1); + ST(0) = sv_2mortal(newSVpv(cwd, 0)); + free(cwd); + SvTAINTED_on(ST(0)); + XSRETURN(1); } XSRETURN_UNDEF; } @@ -243,7 +243,7 @@ XS(XS_Cygwin_pid_to_winpid) pid = (pid_t)SvIV(ST(0)); if ((RETVAL = cygwin_internal(CW_CYGWIN_PID_TO_WINPID, pid)) > 0) { - XSprePUSH; PUSHi((IV)RETVAL); + XSprePUSH; PUSHi((IV)RETVAL); XSRETURN(1); } XSRETURN_UNDEF; @@ -288,10 +288,10 @@ XS(XS_Cygwin_win_to_posix_path) src_path = SvPV(ST(0), len); if (items == 2) - absolute_flag = SvTRUE(ST(1)); + absolute_flag = SvTRUE(ST(1)); if (!len) - Perl_croak(aTHX_ "can't convert empty path"); + Perl_croak(aTHX_ "can't convert empty path"); isutf8 = SvUTF8(ST(0)); #if (CYGWIN_VERSION_API_MINOR >= 181) @@ -299,72 +299,72 @@ XS(XS_Cygwin_win_to_posix_path) Size calculation: On overflow let cygwin_conv_path calculate the final size. */ if (isutf8) { - int what = absolute_flag ? CCP_WIN_W_TO_POSIX : CCP_WIN_W_TO_POSIX | CCP_RELATIVE; - STRLEN wlen = sizeof(wchar_t)*(len + 260 + 1001); - wchar_t *wpath = (wchar_t *) safemalloc(sizeof(wchar_t)*len); - wchar_t *wbuf = (wchar_t *) safemalloc(wlen); - if (!IN_BYTES) { - mbstate_t mbs; + int what = absolute_flag ? CCP_WIN_W_TO_POSIX : CCP_WIN_W_TO_POSIX | CCP_RELATIVE; + STRLEN wlen = sizeof(wchar_t)*(len + 260 + 1001); + wchar_t *wpath = (wchar_t *) safemalloc(sizeof(wchar_t)*len); + wchar_t *wbuf = (wchar_t *) safemalloc(wlen); + if (!IN_BYTES) { + mbstate_t mbs; char *oldlocale; SETLOCALE_LOCK; oldlocale = setlocale(LC_CTYPE, NULL); setlocale(LC_CTYPE, "utf-8"); - /* utf8_to_uvchr_buf(src_path, src_path + wlen, wpath) or Encoding::_utf8_to_bytes(sv, "UCS-2BE"); */ - wlen = mbsrtowcs(wpath, (const char**)&src_path, wlen, &mbs); - if (wlen > 0) - err = cygwin_conv_path(what, wpath, wbuf, wlen); + /* utf8_to_uvchr_buf(src_path, src_path + wlen, wpath) or Encoding::_utf8_to_bytes(sv, "UCS-2BE"); */ + wlen = mbsrtowcs(wpath, (const char**)&src_path, wlen, &mbs); + if (wlen > 0) + err = cygwin_conv_path(what, wpath, wbuf, wlen); if (oldlocale) setlocale(LC_CTYPE, oldlocale); else setlocale(LC_CTYPE, "C"); SETLOCALE_UNLOCK; - } else { /* use bytes; assume already ucs-2 encoded bytestream */ - err = cygwin_conv_path(what, src_path, wbuf, wlen); - } - if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ - int newlen = cygwin_conv_path(what, wpath, wbuf, 0); - wbuf = (wchar_t *) realloc(&wbuf, newlen); - err = cygwin_conv_path(what, wpath, wbuf, newlen); - wlen = newlen; - } - /* utf16_to_utf8(*p, *d, bytlen, *newlen) */ - posix_path = (char *) safemalloc(wlen*3); - Perl_utf16_to_utf8(aTHX_ (U8*)&wpath, (U8*)posix_path, wlen*2, &len); - /* - wlen = wcsrtombs(NULL, (const wchar_t **)&wbuf, wlen, NULL); - posix_path = (char *) safemalloc(wlen+1); - wcsrtombs(posix_path, (const wchar_t **)&wbuf, wlen, NULL); - */ + } else { /* use bytes; assume already ucs-2 encoded bytestream */ + err = cygwin_conv_path(what, src_path, wbuf, wlen); + } + if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ + int newlen = cygwin_conv_path(what, wpath, wbuf, 0); + wbuf = (wchar_t *) realloc(&wbuf, newlen); + err = cygwin_conv_path(what, wpath, wbuf, newlen); + wlen = newlen; + } + /* utf16_to_utf8(*p, *d, bytlen, *newlen) */ + posix_path = (char *) safemalloc(wlen*3); + Perl_utf16_to_utf8(aTHX_ (U8*)&wpath, (U8*)posix_path, wlen*2, &len); + /* + wlen = wcsrtombs(NULL, (const wchar_t **)&wbuf, wlen, NULL); + posix_path = (char *) safemalloc(wlen+1); + wcsrtombs(posix_path, (const wchar_t **)&wbuf, wlen, NULL); + */ } else { - int what = absolute_flag ? CCP_WIN_A_TO_POSIX : CCP_WIN_A_TO_POSIX | CCP_RELATIVE; - posix_path = (char *) safemalloc (len + 260 + 1001); - err = cygwin_conv_path(what, src_path, posix_path, len + 260 + 1001); - if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ - int newlen = cygwin_conv_path(what, src_path, posix_path, 0); - posix_path = (char *) realloc(&posix_path, newlen); - err = cygwin_conv_path(what, src_path, posix_path, newlen); - } + int what = absolute_flag ? CCP_WIN_A_TO_POSIX : CCP_WIN_A_TO_POSIX | CCP_RELATIVE; + posix_path = (char *) safemalloc (len + 260 + 1001); + err = cygwin_conv_path(what, src_path, posix_path, len + 260 + 1001); + if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ + int newlen = cygwin_conv_path(what, src_path, posix_path, 0); + posix_path = (char *) realloc(&posix_path, newlen); + err = cygwin_conv_path(what, src_path, posix_path, newlen); + } } #else posix_path = (char *) safemalloc (len + 260 + 1001); if (absolute_flag) - err = cygwin_conv_to_full_posix_path(src_path, posix_path); + err = cygwin_conv_to_full_posix_path(src_path, posix_path); else - err = cygwin_conv_to_posix_path(src_path, posix_path); + err = cygwin_conv_to_posix_path(src_path, posix_path); #endif if (!err) { - EXTEND(SP, 1); - ST(0) = sv_2mortal(newSVpv(posix_path, 0)); - if (isutf8) { /* src was utf-8, so result should also */ - /* TODO: convert ANSI (local windows encoding) to utf-8 on cygwin-1.5 */ - SvUTF8_on(ST(0)); - } - safefree(posix_path); + EXTEND(SP, 1); + ST(0) = sv_2mortal(newSVpv(posix_path, 0)); + if (isutf8) { /* src was utf-8, so result should also */ + /* TODO: convert ANSI (local windows encoding) to utf-8 on cygwin-1.5 */ + SvUTF8_on(ST(0)); + } + safefree(posix_path); XSRETURN(1); } else { - safefree(posix_path); - XSRETURN_UNDEF; + safefree(posix_path); + XSRETURN_UNDEF; } } @@ -382,79 +382,79 @@ XS(XS_Cygwin_posix_to_win_path) src_path = SvPVx(ST(0), len); if (items == 2) - absolute_flag = SvTRUE(ST(1)); + absolute_flag = SvTRUE(ST(1)); if (!len) - Perl_croak(aTHX_ "can't convert empty path"); + Perl_croak(aTHX_ "can't convert empty path"); isutf8 = SvUTF8(ST(0)); #if (CYGWIN_VERSION_API_MINOR >= 181) /* Check utf8 flag and use wide api then. Size calculation: On overflow let cygwin_conv_path calculate the final size. */ if (isutf8) { - int what = absolute_flag ? CCP_POSIX_TO_WIN_W : CCP_POSIX_TO_WIN_W | CCP_RELATIVE; - int wlen = sizeof(wchar_t)*(len + 260 + 1001); - wchar_t *wpath = (wchar_t *) safemalloc(sizeof(wchar_t)*len); - wchar_t *wbuf = (wchar_t *) safemalloc(wlen); - char *oldlocale; + int what = absolute_flag ? CCP_POSIX_TO_WIN_W : CCP_POSIX_TO_WIN_W | CCP_RELATIVE; + int wlen = sizeof(wchar_t)*(len + 260 + 1001); + wchar_t *wpath = (wchar_t *) safemalloc(sizeof(wchar_t)*len); + wchar_t *wbuf = (wchar_t *) safemalloc(wlen); + char *oldlocale; SETLOCALE_LOCK; - oldlocale = setlocale(LC_CTYPE, NULL); - setlocale(LC_CTYPE, "utf-8"); - if (!IN_BYTES) { - mbstate_t mbs; - /* utf8_to_uvchr_buf(src_path, src_path + wlen, wpath) or Encoding::_utf8_to_bytes(sv, "UCS-2BE"); */ - wlen = mbsrtowcs(wpath, (const char**)&src_path, wlen, &mbs); - if (wlen > 0) - err = cygwin_conv_path(what, wpath, wbuf, wlen); - } else { /* use bytes; assume already ucs-2 encoded bytestream */ - err = cygwin_conv_path(what, src_path, wbuf, wlen); - } - if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ - int newlen = cygwin_conv_path(what, wpath, wbuf, 0); - wbuf = (wchar_t *) realloc(&wbuf, newlen); - err = cygwin_conv_path(what, wpath, wbuf, newlen); - wlen = newlen; - } - /* also see utf8.c: Perl_utf16_to_utf8() or Encoding::_bytes_to_utf8(sv, "UCS-2BE"); */ - wlen = wcsrtombs(NULL, (const wchar_t **)&wbuf, wlen, NULL); - win_path = (char *) safemalloc(wlen+1); - wcsrtombs(win_path, (const wchar_t **)&wbuf, wlen, NULL); - if (oldlocale) setlocale(LC_CTYPE, oldlocale); - else setlocale(LC_CTYPE, "C"); + oldlocale = setlocale(LC_CTYPE, NULL); + setlocale(LC_CTYPE, "utf-8"); + if (!IN_BYTES) { + mbstate_t mbs; + /* utf8_to_uvchr_buf(src_path, src_path + wlen, wpath) or Encoding::_utf8_to_bytes(sv, "UCS-2BE"); */ + wlen = mbsrtowcs(wpath, (const char**)&src_path, wlen, &mbs); + if (wlen > 0) + err = cygwin_conv_path(what, wpath, wbuf, wlen); + } else { /* use bytes; assume already ucs-2 encoded bytestream */ + err = cygwin_conv_path(what, src_path, wbuf, wlen); + } + if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ + int newlen = cygwin_conv_path(what, wpath, wbuf, 0); + wbuf = (wchar_t *) realloc(&wbuf, newlen); + err = cygwin_conv_path(what, wpath, wbuf, newlen); + wlen = newlen; + } + /* also see utf8.c: Perl_utf16_to_utf8() or Encoding::_bytes_to_utf8(sv, "UCS-2BE"); */ + wlen = wcsrtombs(NULL, (const wchar_t **)&wbuf, wlen, NULL); + win_path = (char *) safemalloc(wlen+1); + wcsrtombs(win_path, (const wchar_t **)&wbuf, wlen, NULL); + if (oldlocale) setlocale(LC_CTYPE, oldlocale); + else setlocale(LC_CTYPE, "C"); SETLOCALE_UNLOCK; } else { - int what = absolute_flag ? CCP_POSIX_TO_WIN_A : CCP_POSIX_TO_WIN_A | CCP_RELATIVE; - win_path = (char *) safemalloc(len + 260 + 1001); - err = cygwin_conv_path(what, src_path, win_path, len + 260 + 1001); - if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ - int newlen = cygwin_conv_path(what, src_path, win_path, 0); - win_path = (char *) realloc(&win_path, newlen); - err = cygwin_conv_path(what, src_path, win_path, newlen); - } + int what = absolute_flag ? CCP_POSIX_TO_WIN_A : CCP_POSIX_TO_WIN_A | CCP_RELATIVE; + win_path = (char *) safemalloc(len + 260 + 1001); + err = cygwin_conv_path(what, src_path, win_path, len + 260 + 1001); + if (err == ENOSPC) { /* our space assumption was wrong, not enough space */ + int newlen = cygwin_conv_path(what, src_path, win_path, 0); + win_path = (char *) realloc(&win_path, newlen); + err = cygwin_conv_path(what, src_path, win_path, newlen); + } } #else if (isutf8) - Perl_warn(aTHX_ "can't convert utf8 path"); + Perl_warn(aTHX_ "can't convert utf8 path"); win_path = (char *) safemalloc(len + 260 + 1001); if (absolute_flag) - err = cygwin_conv_to_full_win32_path(src_path, win_path); + err = cygwin_conv_to_full_win32_path(src_path, win_path); else - err = cygwin_conv_to_win32_path(src_path, win_path); + err = cygwin_conv_to_win32_path(src_path, win_path); #endif if (!err) { - EXTEND(SP, 1); - ST(0) = sv_2mortal(newSVpv(win_path, 0)); - if (isutf8) { - SvUTF8_on(ST(0)); - } - safefree(win_path); - XSRETURN(1); + EXTEND(SP, 1); + ST(0) = sv_2mortal(newSVpv(win_path, 0)); + if (isutf8) { + SvUTF8_on(ST(0)); + } + safefree(win_path); + XSRETURN(1); } else { - safefree(win_path); - XSRETURN_UNDEF; + safefree(win_path); + XSRETURN_UNDEF; } } @@ -469,12 +469,12 @@ XS(XS_Cygwin_mount_table) setmntent (0, 0); while ((mnt = getmntent (0))) { - AV* av = newAV(); - av_push(av, newSVpvn(mnt->mnt_dir, strlen(mnt->mnt_dir))); - av_push(av, newSVpvn(mnt->mnt_fsname, strlen(mnt->mnt_fsname))); - av_push(av, newSVpvn(mnt->mnt_type, strlen(mnt->mnt_type))); - av_push(av, newSVpvn(mnt->mnt_opts, strlen(mnt->mnt_opts))); - XPUSHs(sv_2mortal(newRV_noinc((SV*)av))); + AV* av = newAV(); + av_push(av, newSVpvn(mnt->mnt_dir, strlen(mnt->mnt_dir))); + av_push(av, newSVpvn(mnt->mnt_fsname, strlen(mnt->mnt_fsname))); + av_push(av, newSVpvn(mnt->mnt_type, strlen(mnt->mnt_type))); + av_push(av, newSVpvn(mnt->mnt_opts, strlen(mnt->mnt_opts))); + XPUSHs(sv_2mortal(newRV_noinc((SV*)av))); } endmntent (0); PUTBACK; @@ -493,13 +493,13 @@ XS(XS_Cygwin_mount_flags) pathname = SvPV_nolen(ST(0)); if (strEQ(pathname, "/cygdrive")) { - char user[PATH_MAX]; - char system[PATH_MAX]; - char user_flags[PATH_MAX]; - char system_flags[PATH_MAX]; + char user[PATH_MAX]; + char system[PATH_MAX]; + char user_flags[PATH_MAX]; + char system_flags[PATH_MAX]; - cygwin_internal (CW_GET_CYGDRIVE_INFO, user, system, - user_flags, system_flags); + cygwin_internal (CW_GET_CYGDRIVE_INFO, user, system, + user_flags, system_flags); if (strlen(user) > 0) { sprintf(flags, "%s,cygdrive,%s", user_flags, user); @@ -507,56 +507,56 @@ XS(XS_Cygwin_mount_flags) sprintf(flags, "%s,cygdrive,%s", system_flags, system); } - ST(0) = sv_2mortal(newSVpv(flags, 0)); - XSRETURN(1); + ST(0) = sv_2mortal(newSVpv(flags, 0)); + XSRETURN(1); } else { - struct mntent *mnt; - int found = 0; - setmntent (0, 0); - while ((mnt = getmntent (0))) { - if (strEQ(pathname, mnt->mnt_dir)) { - strcpy(flags, mnt->mnt_type); - if (strlen(mnt->mnt_opts) > 0) { - strcat(flags, ","); - strcat(flags, mnt->mnt_opts); - } - found++; - break; - } - } - endmntent (0); - - /* Check if arg is the current volume moint point if not default, - * and then use CW_GET_CYGDRIVE_INFO also. - */ - if (!found) { - char user[PATH_MAX]; - char system[PATH_MAX]; - char user_flags[PATH_MAX]; - char system_flags[PATH_MAX]; - - cygwin_internal (CW_GET_CYGDRIVE_INFO, user, system, - user_flags, system_flags); - - if (strlen(user) > 0) { - if (strNE(user,pathname)) { - sprintf(flags, "%s,cygdrive,%s", user_flags, user); - found++; - } - } else { - if (strNE(user,pathname)) { - sprintf(flags, "%s,cygdrive,%s", system_flags, system); - found++; - } - } - } - if (found) { - ST(0) = sv_2mortal(newSVpv(flags, 0)); - XSRETURN(1); - } else { - XSRETURN_UNDEF; - } + struct mntent *mnt; + int found = 0; + setmntent (0, 0); + while ((mnt = getmntent (0))) { + if (strEQ(pathname, mnt->mnt_dir)) { + strcpy(flags, mnt->mnt_type); + if (strlen(mnt->mnt_opts) > 0) { + strcat(flags, ","); + strcat(flags, mnt->mnt_opts); + } + found++; + break; + } + } + endmntent (0); + + /* Check if arg is the current volume moint point if not default, + * and then use CW_GET_CYGDRIVE_INFO also. + */ + if (!found) { + char user[PATH_MAX]; + char system[PATH_MAX]; + char user_flags[PATH_MAX]; + char system_flags[PATH_MAX]; + + cygwin_internal (CW_GET_CYGDRIVE_INFO, user, system, + user_flags, system_flags); + + if (strlen(user) > 0) { + if (strNE(user,pathname)) { + sprintf(flags, "%s,cygdrive,%s", user_flags, user); + found++; + } + } else { + if (strNE(user,pathname)) { + sprintf(flags, "%s,cygdrive,%s", system_flags, system); + found++; + } + } + } + if (found) { + ST(0) = sv_2mortal(newSVpv(flags, 0)); + XSRETURN(1); + } else { + XSRETURN_UNDEF; + } } } @@ -66,10 +66,10 @@ Perl_vdeb(pTHX_ const char *pat, va_list *args) PERL_ARGS_ASSERT_VDEB; if (DEBUG_v_TEST) - PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t", - (long)PerlProc_getpid(), display_file, line); + 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); + PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", display_file, line); (void) PerlIO_vprintf(Perl_debug_log, pat, *args); #else PERL_UNUSED_CONTEXT; @@ -83,15 +83,15 @@ Perl_debstackptrs(pTHX) { #ifdef DEBUGGING PerlIO_printf(Perl_debug_log, - "%8" UVxf " %8" UVxf " %8" IVdf " %8" IVdf " %8" IVdf "\n", - PTR2UV(PL_curstack), PTR2UV(PL_stack_base), - (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base), - (IV)(PL_stack_max-PL_stack_base)); + "%8" UVxf " %8" UVxf " %8" IVdf " %8" IVdf " %8" IVdf "\n", + PTR2UV(PL_curstack), PTR2UV(PL_stack_base), + (IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base), + (IV)(PL_stack_max-PL_stack_base)); PerlIO_printf(Perl_debug_log, - "%8" UVxf " %8" UVxf " %8" UVuf " %8" UVuf " %8" UVuf "\n", - PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)), - PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)), - PTR2UV(AvMAX(PL_curstack))); + "%8" UVxf " %8" UVxf " %8" UVuf " %8" UVuf " %8" UVuf "\n", + PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)), + PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)), + PTR2UV(AvMAX(PL_curstack))); #else PERL_UNUSED_CONTEXT; #endif /* DEBUGGING */ @@ -110,7 +110,7 @@ Perl_debstackptrs(pTHX) STATIC void S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, - I32 mark_min, I32 mark_max) + I32 mark_min, I32 mark_max) { #ifdef DEBUGGING I32 i = stack_max - 30; @@ -119,30 +119,30 @@ S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, PERL_ARGS_ASSERT_DEB_STACK_N; if (i < stack_min) - i = stack_min; + i = stack_min; while (++markscan <= PL_markstack + mark_max) - if (*markscan >= i) - break; + if (*markscan >= i) + break; if (i > stack_min) - PerlIO_printf(Perl_debug_log, "... "); + PerlIO_printf(Perl_debug_log, "... "); if (stack_base[0] != &PL_sv_undef || stack_max < 0) - PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); + PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); do { - ++i; - if (markscan <= PL_markstack + mark_max && *markscan < i) { - do { - ++markscan; - (void)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])); + ++i; + if (markscan <= PL_markstack + mark_max && *markscan < i) { + do { + ++markscan; + (void)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"); @@ -164,14 +164,14 @@ Perl_debstack(pTHX) { #ifndef SKIP_DEBUGGING if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) - return 0; + return 0; PerlIO_printf(Perl_debug_log, " => "); deb_stack_n(PL_stack_base, - 0, - PL_stack_sp - PL_stack_base, - PL_curstackinfo->si_markoff, - PL_markstack_ptr - PL_markstack); + 0, + PL_stack_sp - PL_stack_base, + PL_curstackinfo->si_markoff, + PL_markstack_ptr - PL_markstack); #endif /* SKIP_DEBUGGING */ @@ -209,7 +209,7 @@ Perl_deb_stack_all(pTHX) /* rewind to start of chain */ si = PL_curstackinfo; while (si->si_prev) - si = si->si_prev; + si = si->si_prev; si_ix=0; for (;;) @@ -218,107 +218,107 @@ Perl_deb_stack_all(pTHX) const char * const si_name = si_name_ix < C_ARRAY_LENGTH(si_names) ? si_names[si_name_ix] : "????"; - I32 ix; - PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s\n", - (IV)si_ix, si_name); - - for (ix=0; ix<=si->si_cxix; ix++) { - - const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]); - PerlIO_printf(Perl_debug_log, - " CX %" IVdf ": %-6s => ", - (IV)ix, PL_block_type[CxTYPE(cx)] - ); - /* substitution contexts don't save stack pointers etc) */ - if (CxTYPE(cx) == CXt_SUBST) - PerlIO_printf(Perl_debug_log, "\n"); - else { - - /* Find the current context's stack range by searching - * forward for any higher contexts using this stack; failing - * that, it will be equal to the size of the stack for old - * stacks, or PL_stack_sp for the current stack - */ - - I32 i, stack_min, stack_max, mark_min, mark_max; - const PERL_CONTEXT *cx_n = NULL; - const PERL_SI *si_n; + I32 ix; + PerlIO_printf(Perl_debug_log, "STACK %" IVdf ": %s\n", + (IV)si_ix, si_name); + + for (ix=0; ix<=si->si_cxix; ix++) { + + const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]); + PerlIO_printf(Perl_debug_log, + " CX %" IVdf ": %-6s => ", + (IV)ix, PL_block_type[CxTYPE(cx)] + ); + /* substitution contexts don't save stack pointers etc) */ + if (CxTYPE(cx) == CXt_SUBST) + PerlIO_printf(Perl_debug_log, "\n"); + else { + + /* Find the current context's stack range by searching + * forward for any higher contexts using this stack; failing + * that, it will be equal to the size of the stack for old + * stacks, or PL_stack_sp for the current stack + */ + + I32 i, stack_min, stack_max, mark_min, mark_max; + const PERL_CONTEXT *cx_n = NULL; + const PERL_SI *si_n; /* there's a separate argument stack per SI, so only * search this one */ - for (i=ix+1; i<=si->si_cxix; i++) { + for (i=ix+1; i<=si->si_cxix; i++) { const PERL_CONTEXT *this_cx = &(si->si_cxstack[i]); if (CxTYPE(this_cx) == CXt_SUBST) - continue; - cx_n = this_cx; - break; - } - - stack_min = cx->blk_oldsp; - - if (cx_n) { - stack_max = cx_n->blk_oldsp; - } - else if (si == PL_curstackinfo) { - stack_max = PL_stack_sp - AvARRAY(si->si_stack); - } - else { - stack_max = AvFILLp(si->si_stack); - } + continue; + cx_n = this_cx; + break; + } + + stack_min = cx->blk_oldsp; + + if (cx_n) { + stack_max = cx_n->blk_oldsp; + } + else if (si == PL_curstackinfo) { + stack_max = PL_stack_sp - AvARRAY(si->si_stack); + } + else { + stack_max = AvFILLp(si->si_stack); + } /* for the markstack, there's only one stack shared * between all SIs */ - si_n = si; - i = ix; - cx_n = NULL; - for (;;) { - i++; - if (i > si_n->si_cxix) { - if (si_n == PL_curstackinfo) - break; - else { - si_n = si_n->si_next; - i = 0; - } - } - if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) - continue; - cx_n = &(si_n->si_cxstack[i]); - break; - } - - mark_min = cx->blk_oldmarksp; - if (cx_n) { - mark_max = cx_n->blk_oldmarksp; - } - else { - mark_max = PL_markstack_ptr - PL_markstack; - } - - deb_stack_n(AvARRAY(si->si_stack), - stack_min, stack_max, mark_min, mark_max); - - if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB - || CxTYPE(cx) == CXt_FORMAT) - { - const OP * const retop = cx->blk_sub.retop; - - PerlIO_printf(Perl_debug_log, " retop=%s\n", - retop ? OP_NAME(retop) : "(null)" - ); - } - } - } /* next context */ - - - if (si == PL_curstackinfo) - break; - si = si->si_next; - si_ix++; - if (!si) - break; /* shouldn't happen, but just in case.. */ + si_n = si; + i = ix; + cx_n = NULL; + for (;;) { + i++; + if (i > si_n->si_cxix) { + if (si_n == PL_curstackinfo) + break; + else { + si_n = si_n->si_next; + i = 0; + } + } + if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST) + continue; + cx_n = &(si_n->si_cxstack[i]); + break; + } + + mark_min = cx->blk_oldmarksp; + if (cx_n) { + mark_max = cx_n->blk_oldmarksp; + } + else { + mark_max = PL_markstack_ptr - PL_markstack; + } + + deb_stack_n(AvARRAY(si->si_stack), + stack_min, stack_max, mark_min, mark_max); + + if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB + || CxTYPE(cx) == CXt_FORMAT) + { + const OP * const retop = cx->blk_sub.retop; + + PerlIO_printf(Perl_debug_log, " retop=%s\n", + retop ? OP_NAME(retop) : "(null)" + ); + } + } + } /* next context */ + + + if (si == PL_curstackinfo) + break; + si = si->si_next; + si_ix++; + if (!si) + break; /* shouldn't happen, but just in case.. */ } /* next stackinfo */ PerlIO_printf(Perl_debug_log, "\n"); diff --git a/dist/IO/poll.c b/dist/IO/poll.c index 344a406b52..3ddaa22db4 100644 --- a/dist/IO/poll.c +++ b/dist/IO/poll.c @@ -61,74 +61,74 @@ again: FD_ZERO(&efd); for(i = 0 ; i < (int)nfds ; i++) { - int events = fds[i].events; - int fd = fds[i].fd; + int events = fds[i].events; + int fd = fds[i].fd; - fds[i].revents = 0; + fds[i].revents = 0; - if(fd < 0 || FD_ISSET(fd, &ifd)) - continue; + if(fd < 0 || FD_ISSET(fd, &ifd)) + continue; - if(fd > n) - n = fd; + if(fd > n) + n = fd; - if(events & POLL_CAN_READ) - FD_SET(fd, &rfd); + if(events & POLL_CAN_READ) + FD_SET(fd, &rfd); - if(events & POLL_CAN_WRITE) - FD_SET(fd, &wfd); + if(events & POLL_CAN_WRITE) + FD_SET(fd, &wfd); - if(events & POLL_HAS_EXCP) - FD_SET(fd, &efd); + if(events & POLL_HAS_EXCP) + FD_SET(fd, &efd); } if(timeout >= 0) { - timebuf.tv_sec = timeout / 1000; - timebuf.tv_usec = (timeout % 1000) * 1000; - tbuf = &timebuf; + timebuf.tv_sec = timeout / 1000; + timebuf.tv_usec = (timeout % 1000) * 1000; + tbuf = &timebuf; } err = select(n+1,&rfd,&wfd,&efd,tbuf); if(err < 0) { #ifdef HAS_FSTAT - if(errno == EBADF) { - for(i = 0 ; i < nfds ; i++) { - struct stat buf; - if((fstat(fds[i].fd,&buf) < 0) && (errno == EBADF)) { - FD_SET(fds[i].fd, &ifd); - goto again; - } - } - } + if(errno == EBADF) { + for(i = 0 ; i < nfds ; i++) { + struct stat buf; + if((fstat(fds[i].fd,&buf) < 0) && (errno == EBADF)) { + FD_SET(fds[i].fd, &ifd); + goto again; + } + } + } #endif /* HAS_FSTAT */ - return err; + return err; } count = 0; for(i = 0 ; i < (int)nfds ; i++) { - int revents = (fds[i].events & POLL_EVENTS_MASK); - int fd = fds[i].fd; + int revents = (fds[i].events & POLL_EVENTS_MASK); + int fd = fds[i].fd; - if(fd < 0) - continue; + if(fd < 0) + continue; - if(FD_ISSET(fd, &ifd)) - revents = POLLNVAL; - else { - if(!FD_ISSET(fd, &rfd)) - revents &= ~POLL_CAN_READ; + if(FD_ISSET(fd, &ifd)) + revents = POLLNVAL; + else { + if(!FD_ISSET(fd, &rfd)) + revents &= ~POLL_CAN_READ; - if(!FD_ISSET(fd, &wfd)) - revents &= ~POLL_CAN_WRITE; + if(!FD_ISSET(fd, &wfd)) + revents &= ~POLL_CAN_WRITE; - if(!FD_ISSET(fd, &efd)) - revents &= ~POLL_HAS_EXCP; - } + if(!FD_ISSET(fd, &efd)) + revents &= ~POLL_HAS_EXCP; + } - if((fds[i].revents = revents) != 0) - count++; + if((fds[i].revents = revents) != 0) + count++; } return count; diff --git a/djgpp/djgpp.c b/djgpp/djgpp.c index 24d12f254b..ddadeb7d53 100644 --- a/djgpp/djgpp.c +++ b/djgpp/djgpp.c @@ -107,7 +107,7 @@ convretcode (pTHX_ int rc,char *prog,int fl) { if (rc < 0 && ckWARN(WARN_EXEC)) Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't %s \"%s\": %s", - fl ? "exec" : "spawn",prog,Strerror (errno)); + fl ? "exec" : "spawn",prog,Strerror (errno)); if (rc >= 0) return rc << 8; return -1; @@ -155,13 +155,13 @@ do_spawn2 (pTHX_ char *cmd,int execf) ENTER; if ((shell=getenv("SHELL"))==NULL && (shell=getenv("COMSPEC"))==NULL) - shell="c:\\command.com" EXTRA; + shell="c:\\command.com" EXTRA; unixysh=_is_unixy_shell (shell); metachars=unixysh ? "$&*(){}[]'\";\\?>|<~`\n" EXTRA : "*?[|<>\"\\" EXTRA; while (*cmd && isSPACE(*cmd)) - cmd++; + cmd++; if (strBEGINs (cmd,"/bin/sh") && isSPACE (cmd[7])) cmd+=5; @@ -181,20 +181,20 @@ do_spawn2 (pTHX_ char *cmd,int execf) goto doshell; } for (s=cmd; *s; s++) - if (strchr (metachars,*s)) - { - if (*s=='\n' && s[1]=='\0') - { - *s='\0'; - break; - } + if (strchr (metachars,*s)) + { + if (*s=='\n' && s[1]=='\0') + { + *s='\0'; + break; + } doshell: - if (execf==EXECF_EXEC) + if (execf==EXECF_EXEC) result = convretcode (execl (shell,shell,unixysh ? "-c" : "/c",cmd,NULL),cmd,execf); - else - result = convretcode (system (cmd),cmd,execf); - goto leave; - } + else + result = convretcode (system (cmd),cmd,execf); + goto leave; + } Newx (argv,(s-cmd)/2+2,char*); SAVEFREEPV(argv); @@ -202,17 +202,17 @@ doshell: SAVEFREEPV(cmd); a=argv; for (s=cmd; *s;) { - while (*s && isSPACE (*s)) s++; - if (*s) - *(a++)=s; - while (*s && !isSPACE (*s)) s++; - if (*s) - *s++='\0'; + while (*s && isSPACE (*s)) s++; + if (*s) + *(a++)=s; + while (*s && !isSPACE (*s)) s++; + if (*s) + *s++='\0'; } *a=NULL; if (!argv[0]) { result = -1; - goto leave; + goto leave; } if (execf==EXECF_EXEC) @@ -362,7 +362,7 @@ XS(dos_GetCwd) ST(0)=sv_newmortal (); if (getcwd (tmp,PATH_MAX+1)!=NULL) sv_setpv ((SV*)ST(0),tmp); - SvTAINTED_on(ST(0)); + SvTAINTED_on(ST(0)); } XSRETURN (1); } @@ -378,14 +378,14 @@ XS(XS_Cwd_sys_cwd) { dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); + Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); { - char p[MAXPATHLEN]; - char * RETVAL; - RETVAL = getcwd(p, MAXPATHLEN); - ST(0) = sv_newmortal(); - sv_setpv((SV*)ST(0), RETVAL); - SvTAINTED_on(ST(0)); + char p[MAXPATHLEN]; + char * RETVAL; + RETVAL = getcwd(p, MAXPATHLEN); + ST(0) = sv_newmortal(); + sv_setpv((SV*)ST(0), RETVAL); + SvTAINTED_on(ST(0)); } XSRETURN(1); } @@ -453,9 +453,9 @@ djgpp_fflush (FILE *fp) int res; if ((res = fflush(fp)) == 0 && fp) { - Stat_t s; - if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode)) - res = fsync(fileno(fp)); + Stat_t s; + if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode)) + res = fsync(fileno(fp)); } /* * If the flush succeeded but set end-of-file, we need to clear @@ -83,7 +83,7 @@ Perl_setfd_cloexec_for_nonsysfd(pTHX_ int fd) { assert(fd >= 0); if(fd > PL_maxsysfd) - setfd_cloexec(fd); + setfd_cloexec(fd); } void @@ -91,96 +91,96 @@ Perl_setfd_inhexec_for_sysfd(pTHX_ int fd) { assert(fd >= 0); if(fd <= PL_maxsysfd) - setfd_inhexec(fd); + setfd_inhexec(fd); } void Perl_setfd_cloexec_or_inhexec_by_sysfdness(pTHX_ int fd) { assert(fd >= 0); if(fd <= PL_maxsysfd) - setfd_inhexec(fd); + setfd_inhexec(fd); else - setfd_cloexec(fd); + setfd_cloexec(fd); } #define DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ - do { \ - int res = (GENOPEN_NORMAL); \ - if(LIKELY(res != -1)) GENSETFD_CLOEXEC; \ - return res; \ - } while(0) + do { \ + int res = (GENOPEN_NORMAL); \ + if(LIKELY(res != -1)) GENSETFD_CLOEXEC; \ + return res; \ + } while(0) #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) && \ - defined(F_GETFD) + defined(F_GETFD) enum { CLOEXEC_EXPERIMENT = 0, CLOEXEC_AT_OPEN, CLOEXEC_AFTER_OPEN }; # define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \ - GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ - do { \ - switch (strategy) { \ - case CLOEXEC_EXPERIMENT: default: { \ - int res = (GENOPEN_CLOEXEC), eno; \ - if (LIKELY(res != -1)) { \ - int fdflags = fcntl((TESTFD), F_GETFD); \ - if (LIKELY(fdflags != -1) && \ - LIKELY(fdflags & FD_CLOEXEC)) { \ - strategy = CLOEXEC_AT_OPEN; \ - } else { \ - strategy = CLOEXEC_AFTER_OPEN; \ - GENSETFD_CLOEXEC; \ - } \ - } else if (UNLIKELY((eno = errno) == EINVAL || \ - eno == ENOSYS)) { \ - res = (GENOPEN_NORMAL); \ - if (LIKELY(res != -1)) { \ - strategy = CLOEXEC_AFTER_OPEN; \ - GENSETFD_CLOEXEC; \ - } else if (!LIKELY((eno = errno) == EINVAL || \ - eno == ENOSYS)) { \ - strategy = CLOEXEC_AFTER_OPEN; \ - } \ - } \ - return res; \ - } \ - case CLOEXEC_AT_OPEN: \ - return (GENOPEN_CLOEXEC); \ - case CLOEXEC_AFTER_OPEN: \ - DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC); \ - } \ - } while(0) + GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ + do { \ + switch (strategy) { \ + case CLOEXEC_EXPERIMENT: default: { \ + int res = (GENOPEN_CLOEXEC), eno; \ + if (LIKELY(res != -1)) { \ + int fdflags = fcntl((TESTFD), F_GETFD); \ + if (LIKELY(fdflags != -1) && \ + LIKELY(fdflags & FD_CLOEXEC)) { \ + strategy = CLOEXEC_AT_OPEN; \ + } else { \ + strategy = CLOEXEC_AFTER_OPEN; \ + GENSETFD_CLOEXEC; \ + } \ + } else if (UNLIKELY((eno = errno) == EINVAL || \ + eno == ENOSYS)) { \ + res = (GENOPEN_NORMAL); \ + if (LIKELY(res != -1)) { \ + strategy = CLOEXEC_AFTER_OPEN; \ + GENSETFD_CLOEXEC; \ + } else if (!LIKELY((eno = errno) == EINVAL || \ + eno == ENOSYS)) { \ + strategy = CLOEXEC_AFTER_OPEN; \ + } \ + } \ + return res; \ + } \ + case CLOEXEC_AT_OPEN: \ + return (GENOPEN_CLOEXEC); \ + case CLOEXEC_AFTER_OPEN: \ + DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC); \ + } \ + } while(0) #else # define DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, TESTFD, GENOPEN_CLOEXEC, \ - GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ - DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) + GENOPEN_NORMAL, GENSETFD_CLOEXEC) \ + DO_GENOPEN_THEN_CLOEXEC(GENOPEN_NORMAL, GENSETFD_CLOEXEC) #endif #define DO_ONEOPEN_THEN_CLOEXEC(ONEOPEN_NORMAL) \ - do { \ - int fd; \ - DO_GENOPEN_THEN_CLOEXEC(fd = (ONEOPEN_NORMAL), \ - setfd_cloexec(fd)); \ - } while(0) + do { \ + int fd; \ + DO_GENOPEN_THEN_CLOEXEC(fd = (ONEOPEN_NORMAL), \ + setfd_cloexec(fd)); \ + } while(0) #define DO_ONEOPEN_EXPERIMENTING_CLOEXEC(strategy, \ ONEOPEN_CLOEXEC, ONEOPEN_NORMAL) \ - do { \ - int fd; \ - DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ + do { \ + int fd; \ + DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ fd, \ fd = (ONEOPEN_CLOEXEC), \ - fd = (ONEOPEN_NORMAL), setfd_cloexec(fd)); \ - } while(0) + fd = (ONEOPEN_NORMAL), setfd_cloexec(fd)); \ + } while(0) #define DO_PIPESETFD_CLOEXEC(PIPEFD) \ - do { \ - setfd_cloexec((PIPEFD)[0]); \ - setfd_cloexec((PIPEFD)[1]); \ - } while(0) + do { \ + setfd_cloexec((PIPEFD)[0]); \ + setfd_cloexec((PIPEFD)[1]); \ + } while(0) #define DO_PIPEOPEN_THEN_CLOEXEC(PIPEFD, PIPEOPEN_NORMAL) \ - DO_GENOPEN_THEN_CLOEXEC(PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) + DO_GENOPEN_THEN_CLOEXEC(PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) #define DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(strategy, PIPEFD, PIPEOPEN_CLOEXEC, \ - PIPEOPEN_NORMAL) \ - DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ + PIPEOPEN_NORMAL) \ + DO_GENOPEN_EXPERIMENTING_CLOEXEC(strategy, \ (PIPEFD)[0], PIPEOPEN_CLOEXEC, \ - PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) + PIPEOPEN_NORMAL, DO_PIPESETFD_CLOEXEC(PIPEFD)) int Perl_PerlLIO_dup_cloexec(pTHX_ int oldfd) @@ -193,8 +193,8 @@ Perl_PerlLIO_dup_cloexec(pTHX_ int oldfd) */ DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_dup, - fcntl(oldfd, F_DUPFD_CLOEXEC, 0), - PerlLIO_dup(oldfd)); + fcntl(oldfd, F_DUPFD_CLOEXEC, 0), + PerlLIO_dup(oldfd)); #else DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_dup(oldfd)); #endif @@ -211,8 +211,8 @@ Perl_PerlLIO_dup2_cloexec(pTHX_ int oldfd, int newfd) */ DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_dup2, - dup3(oldfd, newfd, O_CLOEXEC), - PerlLIO_dup2(oldfd, newfd)); + dup3(oldfd, newfd, O_CLOEXEC), + PerlLIO_dup2(oldfd, newfd)); #else DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_dup2(oldfd, newfd)); #endif @@ -225,8 +225,8 @@ Perl_PerlLIO_open_cloexec(pTHX_ const char *file, int flag) #if defined(O_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_open, - PerlLIO_open(file, flag | O_CLOEXEC), - PerlLIO_open(file, flag)); + PerlLIO_open(file, flag | O_CLOEXEC), + PerlLIO_open(file, flag)); #else DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_open(file, flag)); #endif @@ -239,8 +239,8 @@ Perl_PerlLIO_open3_cloexec(pTHX_ const char *file, int flag, int perm) #if defined(O_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_open3, - PerlLIO_open3(file, flag | O_CLOEXEC, perm), - PerlLIO_open3(file, flag, perm)); + PerlLIO_open3(file, flag | O_CLOEXEC, perm), + PerlLIO_open3(file, flag, perm)); #else DO_ONEOPEN_THEN_CLOEXEC(PerlLIO_open3(file, flag, perm)); #endif @@ -253,8 +253,8 @@ Perl_my_mkstemp_cloexec(char *templte) #if defined(O_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_mkstemp, - Perl_my_mkostemp(templte, O_CLOEXEC), - Perl_my_mkstemp(templte)); + Perl_my_mkostemp(templte, O_CLOEXEC), + Perl_my_mkstemp(templte)); #else DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkstemp(templte)); #endif @@ -267,8 +267,8 @@ Perl_my_mkostemp_cloexec(char *templte, int flags) #if defined(O_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_mkstemp, - Perl_my_mkostemp(templte, flags | O_CLOEXEC), - Perl_my_mkostemp(templte, flags)); + Perl_my_mkostemp(templte, flags | O_CLOEXEC), + Perl_my_mkostemp(templte, flags)); #else DO_ONEOPEN_THEN_CLOEXEC(Perl_my_mkostemp(templte, flags)); #endif @@ -286,8 +286,8 @@ Perl_PerlProc_pipe_cloexec(pTHX_ int *pipefd) */ # if !defined(PERL_IMPLICIT_SYS) && defined(HAS_PIPE2) && defined(O_CLOEXEC) DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_pipe, pipefd, - pipe2(pipefd, O_CLOEXEC), - PerlProc_pipe(pipefd)); + pipe2(pipefd, O_CLOEXEC), + PerlProc_pipe(pipefd)); # else DO_PIPEOPEN_THEN_CLOEXEC(pipefd, PerlProc_pipe(pipefd)); # endif @@ -302,8 +302,8 @@ Perl_PerlSock_socket_cloexec(pTHX_ int domain, int type, int protocol) # if defined(SOCK_CLOEXEC) DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_socket, - PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol), - PerlSock_socket(domain, type, protocol)); + PerlSock_socket(domain, type | SOCK_CLOEXEC, protocol), + PerlSock_socket(domain, type, protocol)); # else DO_ONEOPEN_THEN_CLOEXEC(PerlSock_socket(domain, type, protocol)); # endif @@ -314,7 +314,7 @@ Perl_PerlSock_accept_cloexec(pTHX_ int listenfd, struct sockaddr *addr, Sock_size_t *addrlen) { # if !defined(PERL_IMPLICIT_SYS) && \ - defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC) + defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC) /* * struct IPerlSock doesn't cover accept4(), and there's no clear * way to extend it, so for the time being this just isn't available @@ -322,8 +322,8 @@ Perl_PerlSock_accept_cloexec(pTHX_ int listenfd, struct sockaddr *addr, */ DO_ONEOPEN_EXPERIMENTING_CLOEXEC( PL_strategy_accept, - accept4(listenfd, addr, addrlen, SOCK_CLOEXEC), - PerlSock_accept(listenfd, addr, addrlen)); + accept4(listenfd, addr, addrlen, SOCK_CLOEXEC), + PerlSock_accept(listenfd, addr, addrlen)); # else DO_ONEOPEN_THEN_CLOEXEC(PerlSock_accept(listenfd, addr, addrlen)); # endif @@ -333,7 +333,7 @@ Perl_PerlSock_accept_cloexec(pTHX_ int listenfd, struct sockaddr *addr, #if defined (HAS_SOCKETPAIR) || \ (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && \ - defined(AF_INET) && defined(PF_INET)) + defined(AF_INET) && defined(PF_INET)) int Perl_PerlSock_socketpair_cloexec(pTHX_ int domain, int type, int protocol, int *pairfd) @@ -341,11 +341,11 @@ Perl_PerlSock_socketpair_cloexec(pTHX_ int domain, int type, int protocol, PERL_ARGS_ASSERT_PERLSOCK_SOCKETPAIR_CLOEXEC; # ifdef SOCK_CLOEXEC DO_PIPEOPEN_EXPERIMENTING_CLOEXEC(PL_strategy_socketpair, pairfd, - PerlSock_socketpair(domain, type | SOCK_CLOEXEC, protocol, pairfd), - PerlSock_socketpair(domain, type, protocol, pairfd)); + PerlSock_socketpair(domain, type | SOCK_CLOEXEC, protocol, pairfd), + PerlSock_socketpair(domain, type, protocol, pairfd)); # else DO_PIPEOPEN_THEN_CLOEXEC(pairfd, - PerlSock_socketpair(domain, type, protocol, pairfd)); + PerlSock_socketpair(domain, type, protocol, pairfd)); # endif } #endif @@ -368,10 +368,10 @@ S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp, /* If currently open - close before we re-open */ if (IoIFP(io)) { - if (IoTYPE(io) == IoTYPE_STD) { - /* This is a clone of one of STD* handles */ - } - else { + if (IoTYPE(io) == IoTYPE_STD) { + /* This is a clone of one of STD* handles */ + } + else { const int old_fd = PerlIO_fileno(IoIFP(io)); if (inRANGE(old_fd, 0, PL_maxsysfd)) { @@ -407,25 +407,25 @@ S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **saveofp, } } } - IoOFP(io) = IoIFP(io) = NULL; + IoOFP(io) = IoIFP(io) = NULL; } return io; } bool Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, - int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, - I32 num_svs) + int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, + I32 num_svs) { PERL_ARGS_ASSERT_DO_OPENN; if (as_raw) { /* sysopen style args, i.e. integer mode and permissions */ - if (num_svs != 0) { - Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld", - (long) num_svs); - } + if (num_svs != 0) { + Perl_croak(aTHX_ "panic: sysopen with multiple args, num_svs=%ld", + (long) num_svs); + } return do_open_raw(gv, oname, len, rawmode, rawperm, NULL); } return do_open6(gv, oname, len, supplied_fp, svp, num_svs); @@ -449,52 +449,52 @@ Perl_do_open_raw(pTHX_ GV *gv, const char *oname, STRLEN len, /* For ease of blame back to 5.000, keep the existing indenting. */ { /* sysopen style args, i.e. integer mode and permissions */ - STRLEN ix = 0; - const int appendtrunc = - 0 + STRLEN ix = 0; + const int appendtrunc = + 0 #ifdef O_APPEND /* Not fully portable. */ - |O_APPEND + |O_APPEND #endif #ifdef O_TRUNC /* Not fully portable. */ - |O_TRUNC + |O_TRUNC #endif - ; - const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc; - int ismodifying; + ; + const int modifyingmode = O_WRONLY|O_RDWR|O_CREAT|appendtrunc; + int ismodifying; SV *namesv; - /* It's not always + /* It's not always - O_RDONLY 0 - O_WRONLY 1 - O_RDWR 2 + O_RDONLY 0 + O_WRONLY 1 + O_RDWR 2 - It might be (in OS/390 and Mac OS Classic it is) + It might be (in OS/390 and Mac OS Classic it is) - O_WRONLY 1 - O_RDONLY 2 - O_RDWR 3 + O_WRONLY 1 + O_RDONLY 2 + O_RDWR 3 - This means that simple & with O_RDWR would look - like O_RDONLY is present. Therefore we have to - be more careful. - */ - if ((ismodifying = (rawmode & modifyingmode))) { - if ((ismodifying & O_WRONLY) == O_WRONLY || - (ismodifying & O_RDWR) == O_RDWR || - (ismodifying & (O_CREAT|appendtrunc))) - TAINT_PROPER("sysopen"); - } - mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */ + This means that simple & with O_RDWR would look + like O_RDONLY is present. Therefore we have to + be more careful. + */ + if ((ismodifying = (rawmode & modifyingmode))) { + if ((ismodifying & O_WRONLY) == O_WRONLY || + (ismodifying & O_RDWR) == O_RDWR || + (ismodifying & (O_CREAT|appendtrunc))) + TAINT_PROPER("sysopen"); + } + mode[ix++] = IoTYPE_NUMERIC; /* Marker to openn to use numeric "sysopen" */ #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) - rawmode |= O_LARGEFILE; /* Transparently largefiley. */ + rawmode |= O_LARGEFILE; /* Transparently largefiley. */ #endif IoTYPE(io) = PerlIO_intmode2str(rawmode, &mode[ix], &writing); - namesv = newSVpvn_flags(oname, len, SVs_TEMP); - fp = PerlIO_openn(aTHX_ NULL, mode, -1, rawmode, rawperm, NULL, 1, &namesv); + namesv = newSVpvn_flags(oname, len, SVs_TEMP); + fp = PerlIO_openn(aTHX_ NULL, mode, -1, rawmode, rawperm, NULL, 1, &namesv); } return openn_cleanup(gv, io, fp, mode, oname, saveifp, saveofp, savefd, savetype, writing, 0, NULL, statbufp); @@ -519,11 +519,11 @@ Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, /* For ease of blame back to 5.000, keep the existing indenting. */ { - /* Regular (non-sys) open */ - char *name; - STRLEN olen = len; - char *tend; - int dodup = 0; + /* Regular (non-sys) open */ + char *name; + STRLEN olen = len; + char *tend; + int dodup = 0; bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0; /* Collect default raw/crlf info from the op */ @@ -536,29 +536,29 @@ Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, out_crlf = (flags & OPpOPEN_OUT_CRLF); } - type = savepvn(oname, len); - tend = type+len; - SAVEFREEPV(type); + type = savepvn(oname, len); + tend = type+len; + SAVEFREEPV(type); /* Lose leading and trailing white space */ - while (isSPACE(*type)) - type++; + while (isSPACE(*type)) + type++; while (tend > type && isSPACE(tend[-1])) - *--tend = '\0'; + *--tend = '\0'; - if (num_svs) { + if (num_svs) { const char *p; STRLEN nlen = 0; - /* New style explicit name, type is just mode and layer info */ + /* New style explicit name, type is just mode and layer info */ #ifdef USE_STDIO - if (SvROK(*svp) && !memchr(oname, '&', len)) { - if (ckWARN(WARN_IO)) - Perl_warner(aTHX_ packWARN(WARN_IO), - "Can't open a reference"); - SETERRNO(EINVAL, LIB_INVARG); + if (SvROK(*svp) && !memchr(oname, '&', len)) { + if (ckWARN(WARN_IO)) + Perl_warner(aTHX_ packWARN(WARN_IO), + "Can't open a reference"); + SETERRNO(EINVAL, LIB_INVARG); fp = NULL; - goto say_false; - } + goto say_false; + } #endif /* USE_STDIO */ p = (SvOK(*svp) || SvGMAGICAL(*svp)) ? SvPV(*svp, nlen) : NULL; @@ -567,331 +567,331 @@ Perl_do_open6(pTHX_ GV *gv, const char *oname, STRLEN len, goto say_false; } - name = p ? savepvn(p, nlen) : savepvs(""); + name = p ? savepvn(p, nlen) : savepvs(""); - SAVEFREEPV(name); - } - else { - name = type; - len = tend-type; - } - IoTYPE(io) = *type; - if ((*type == IoTYPE_RDWR) && /* scary */ + SAVEFREEPV(name); + } + else { + name = type; + len = tend-type; + } + IoTYPE(io) = *type; + if ((*type == IoTYPE_RDWR) && /* scary */ (*(type+1) == IoTYPE_RDONLY || *(type+1) == IoTYPE_WRONLY) && - ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) { - TAINT_PROPER("open"); - mode[1] = *type++; - writing = 1; - } - - if (*type == IoTYPE_PIPE) { - if (num_svs) { - if (type[1] != IoTYPE_STD) { - unknown_open_mode: - Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); - } - type++; - } - do { - type++; - } while (isSPACE(*type)); - if (!num_svs) { - name = type; - len = tend-type; - } - if (*name == '\0') { - /* command is missing 19990114 */ - if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); - errno = EPIPE; + ((!num_svs || (tend > type+1 && tend[-1] != IoTYPE_PIPE)))) { + TAINT_PROPER("open"); + mode[1] = *type++; + writing = 1; + } + + if (*type == IoTYPE_PIPE) { + if (num_svs) { + if (type[1] != IoTYPE_STD) { + unknown_open_mode: + Perl_croak(aTHX_ "Unknown open() mode '%.*s'", (int)olen, oname); + } + type++; + } + do { + type++; + } while (isSPACE(*type)); + if (!num_svs) { + name = type; + len = tend-type; + } + if (*name == '\0') { + /* command is missing 19990114 */ + if (ckWARN(WARN_PIPE)) + Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); + errno = EPIPE; fp = NULL; - goto say_false; - } - if (!(*name == '-' && name[1] == '\0') || num_svs) - TAINT_ENV(); - TAINT_PROPER("piped open"); - if (!num_svs && name[len-1] == '|') { - name[--len] = '\0' ; - if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe"); - } - mode[0] = 'w'; - writing = 1; + goto say_false; + } + if (!(*name == '-' && name[1] == '\0') || num_svs) + TAINT_ENV(); + TAINT_PROPER("piped open"); + if (!num_svs && name[len-1] == '|') { + name[--len] = '\0' ; + if (ckWARN(WARN_PIPE)) + Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't open bidirectional pipe"); + } + mode[0] = 'w'; + writing = 1; if (out_raw) - mode[1] = 'b'; + mode[1] = 'b'; else if (out_crlf) - mode[1] = 't'; - if (num_svs > 1) { - fp = PerlProc_popen_list(mode, num_svs, svp); - } - else { - fp = PerlProc_popen(name,mode); - } - if (num_svs) { - if (*type) { - if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { + mode[1] = 't'; + if (num_svs > 1) { + fp = PerlProc_popen_list(mode, num_svs, svp); + } + else { + fp = PerlProc_popen(name,mode); + } + if (num_svs) { + if (*type) { + if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { fp = NULL; - goto say_false; - } - } - } - } /* IoTYPE_PIPE */ - else if (*type == IoTYPE_WRONLY) { - TAINT_PROPER("open"); - type++; - if (*type == IoTYPE_WRONLY) { - /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */ - mode[0] = IoTYPE(io) = IoTYPE_APPEND; - type++; - } - else { - mode[0] = 'w'; - } - writing = 1; + goto say_false; + } + } + } + } /* IoTYPE_PIPE */ + else if (*type == IoTYPE_WRONLY) { + TAINT_PROPER("open"); + type++; + if (*type == IoTYPE_WRONLY) { + /* Two IoTYPE_WRONLYs in a row make for an IoTYPE_APPEND. */ + mode[0] = IoTYPE(io) = IoTYPE_APPEND; + type++; + } + else { + mode[0] = 'w'; + } + writing = 1; if (out_raw) - mode[1] = 'b'; + mode[1] = 'b'; else if (out_crlf) - mode[1] = 't'; - if (*type == '&') { - duplicity: - dodup = PERLIO_DUP_FD; - type++; - if (*type == '=') { - dodup = 0; - type++; - } - if (!num_svs && !*type && supplied_fp) { - /* "<+&" etc. is used by typemaps */ - fp = supplied_fp; - } - else { - PerlIO *that_fp = NULL; + mode[1] = 't'; + if (*type == '&') { + duplicity: + dodup = PERLIO_DUP_FD; + type++; + if (*type == '=') { + dodup = 0; + type++; + } + if (!num_svs && !*type && supplied_fp) { + /* "<+&" etc. is used by typemaps */ + fp = supplied_fp; + } + else { + PerlIO *that_fp = NULL; int wanted_fd; UV uv; - if (num_svs > 1) { - /* diag_listed_as: More than one argument to '%s' open */ - Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); - } - while (isSPACE(*type)) - type++; - if (num_svs && ( - SvIOK(*svp) - || (SvPOKp(*svp) && looks_like_number(*svp)) - )) { + if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ + Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); + } + while (isSPACE(*type)) + type++; + if (num_svs && ( + SvIOK(*svp) + || (SvPOKp(*svp) && looks_like_number(*svp)) + )) { wanted_fd = SvUV(*svp); - num_svs = 0; - } - else if (isDIGIT(*type) + num_svs = 0; + } + else if (isDIGIT(*type) && grok_atoUV(type, &uv, NULL) && uv <= INT_MAX ) { wanted_fd = (int)uv; - } - else { - const IO* thatio; - if (num_svs) { - thatio = sv_2io(*svp); - } - else { - GV * const thatgv = gv_fetchpvn_flags(type, tend - type, - 0, SVt_PVIO); - thatio = GvIO(thatgv); - } - if (!thatio) { + } + else { + const IO* thatio; + if (num_svs) { + thatio = sv_2io(*svp); + } + else { + GV * const thatgv = gv_fetchpvn_flags(type, tend - type, + 0, SVt_PVIO); + thatio = GvIO(thatgv); + } + if (!thatio) { #ifdef EINVAL - SETERRNO(EINVAL,SS_IVCHAN); + SETERRNO(EINVAL,SS_IVCHAN); #endif fp = NULL; - goto say_false; - } - if ((that_fp = IoIFP(thatio))) { - /* Flush stdio buffer before dup. --mjd - * Unfortunately SEEK_CURing 0 seems to - * be optimized away on most platforms; - * only Solaris and Linux seem to flush - * on that. --jhi */ - /* On the other hand, do all platforms - * take gracefully to flushing a read-only - * filehandle? Perhaps we should do - * fsetpos(src)+fgetpos(dst)? --nik */ - PerlIO_flush(that_fp); - wanted_fd = PerlIO_fileno(that_fp); - /* When dup()ing STDIN, STDOUT or STDERR - * explicitly set appropriate access mode */ - if (that_fp == PerlIO_stdout() - || that_fp == PerlIO_stderr()) - IoTYPE(io) = IoTYPE_WRONLY; - else if (that_fp == PerlIO_stdin()) + goto say_false; + } + if ((that_fp = IoIFP(thatio))) { + /* Flush stdio buffer before dup. --mjd + * Unfortunately SEEK_CURing 0 seems to + * be optimized away on most platforms; + * only Solaris and Linux seem to flush + * on that. --jhi */ + /* On the other hand, do all platforms + * take gracefully to flushing a read-only + * filehandle? Perhaps we should do + * fsetpos(src)+fgetpos(dst)? --nik */ + PerlIO_flush(that_fp); + wanted_fd = PerlIO_fileno(that_fp); + /* When dup()ing STDIN, STDOUT or STDERR + * explicitly set appropriate access mode */ + if (that_fp == PerlIO_stdout() + || that_fp == PerlIO_stderr()) + IoTYPE(io) = IoTYPE_WRONLY; + else if (that_fp == PerlIO_stdin()) IoTYPE(io) = IoTYPE_RDONLY; - /* When dup()ing a socket, say result is - * one as well */ - else if (IoTYPE(thatio) == IoTYPE_SOCKET) - IoTYPE(io) = IoTYPE_SOCKET; - } + /* When dup()ing a socket, say result is + * one as well */ + else if (IoTYPE(thatio) == IoTYPE_SOCKET) + IoTYPE(io) = IoTYPE_SOCKET; + } else { SETERRNO(EBADF, RMS_IFI); fp = NULL; goto say_false; } - } - if (!num_svs) - type = NULL; - if (that_fp) { - fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup); - } - else { - if (dodup) + } + if (!num_svs) + type = NULL; + if (that_fp) { + fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup); + } + else { + if (dodup) wanted_fd = PerlLIO_dup_cloexec(wanted_fd); - else - was_fdopen = TRUE; + else + was_fdopen = TRUE; if (!(fp = PerlIO_openn(aTHX_ type,mode,wanted_fd,0,0,NULL,num_svs,svp))) { if (dodup && wanted_fd >= 0) PerlLIO_close(wanted_fd); - } - } - } - } /* & */ - else { - while (isSPACE(*type)) - type++; - if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { - type++; - fp = PerlIO_stdout(); - IoTYPE(io) = IoTYPE_STD; - if (num_svs > 1) { - /* diag_listed_as: More than one argument to '%s' open */ - Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD); - } - } - else { - if (num_svs) { + } + } + } + } /* & */ + else { + while (isSPACE(*type)) + type++; + if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { + type++; + fp = PerlIO_stdout(); + IoTYPE(io) = IoTYPE_STD; + if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ + Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD); + } + } + else { + if (num_svs) { fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } else { SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); - type = NULL; + type = NULL; fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); - } - } - } /* !& */ - if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) - goto unknown_open_mode; - } /* IoTYPE_WRONLY */ - else if (*type == IoTYPE_RDONLY) { - do { - type++; - } while (isSPACE(*type)); - mode[0] = 'r'; + } + } + } /* !& */ + if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) + goto unknown_open_mode; + } /* IoTYPE_WRONLY */ + else if (*type == IoTYPE_RDONLY) { + do { + type++; + } while (isSPACE(*type)); + mode[0] = 'r'; if (in_raw) - mode[1] = 'b'; + mode[1] = 'b'; else if (in_crlf) - mode[1] = 't'; - if (*type == '&') { - goto duplicity; - } - if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { - type++; - fp = PerlIO_stdin(); - IoTYPE(io) = IoTYPE_STD; - if (num_svs > 1) { - /* diag_listed_as: More than one argument to '%s' open */ - Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD); - } - } - else { - if (num_svs) { + mode[1] = 't'; + if (*type == '&') { + goto duplicity; + } + if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) { + type++; + fp = PerlIO_stdin(); + IoTYPE(io) = IoTYPE_STD; + if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ + Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD); + } + } + else { + if (num_svs) { fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } else { SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); - type = NULL; + type = NULL; fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); - } - } - if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) - goto unknown_open_mode; - } /* IoTYPE_RDONLY */ - else if ((num_svs && /* '-|...' or '...|' */ - type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || - (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { - if (num_svs) { - type += 2; /* skip over '-|' */ - } - else { - *--tend = '\0'; - while (tend > type && isSPACE(tend[-1])) - *--tend = '\0'; - for (; isSPACE(*type); type++) - ; - name = type; - len = tend-type; - } - if (*name == '\0') { - /* command is missing 19990114 */ - if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); - errno = EPIPE; + } + } + if (!fp && type && *type && *type != ':' && !isIDFIRST(*type)) + goto unknown_open_mode; + } /* IoTYPE_RDONLY */ + else if ((num_svs && /* '-|...' or '...|' */ + type[0] == IoTYPE_STD && type[1] == IoTYPE_PIPE) || + (!num_svs && tend > type+1 && tend[-1] == IoTYPE_PIPE)) { + if (num_svs) { + type += 2; /* skip over '-|' */ + } + else { + *--tend = '\0'; + while (tend > type && isSPACE(tend[-1])) + *--tend = '\0'; + for (; isSPACE(*type); type++) + ; + name = type; + len = tend-type; + } + if (*name == '\0') { + /* command is missing 19990114 */ + if (ckWARN(WARN_PIPE)) + Perl_warner(aTHX_ packWARN(WARN_PIPE), "Missing command in piped open"); + errno = EPIPE; fp = NULL; - goto say_false; - } - if (!(*name == '-' && name[1] == '\0') || num_svs) - TAINT_ENV(); - TAINT_PROPER("piped open"); - mode[0] = 'r'; + goto say_false; + } + if (!(*name == '-' && name[1] == '\0') || num_svs) + TAINT_ENV(); + TAINT_PROPER("piped open"); + mode[0] = 'r'; if (in_raw) - mode[1] = 'b'; + mode[1] = 'b'; else if (in_crlf) - mode[1] = 't'; - - if (num_svs > 1) { - fp = PerlProc_popen_list(mode,num_svs,svp); - } - else { - fp = PerlProc_popen(name,mode); - } - IoTYPE(io) = IoTYPE_PIPE; - if (num_svs) { - while (isSPACE(*type)) - type++; - if (*type) { - if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { + mode[1] = 't'; + + if (num_svs > 1) { + fp = PerlProc_popen_list(mode,num_svs,svp); + } + else { + fp = PerlProc_popen(name,mode); + } + IoTYPE(io) = IoTYPE_PIPE; + if (num_svs) { + while (isSPACE(*type)) + type++; + if (*type) { + if (PerlIO_apply_layers(aTHX_ fp, mode, type) != 0) { fp = NULL; - goto say_false; - } - } - } - } - else { /* layer(Args) */ - if (num_svs) - goto unknown_open_mode; - name = type; - IoTYPE(io) = IoTYPE_RDONLY; - for (; isSPACE(*name); name++) - ; - mode[0] = 'r'; + goto say_false; + } + } + } + } + else { /* layer(Args) */ + if (num_svs) + goto unknown_open_mode; + name = type; + IoTYPE(io) = IoTYPE_RDONLY; + for (; isSPACE(*name); name++) + ; + mode[0] = 'r'; if (in_raw) - mode[1] = 'b'; + mode[1] = 'b'; else if (in_crlf) - mode[1] = 't'; - - if (*name == '-' && name[1] == '\0') { - fp = PerlIO_stdin(); - IoTYPE(io) = IoTYPE_STD; - } - else { - if (num_svs) { + mode[1] = 't'; + + if (*name == '-' && name[1] == '\0') { + fp = PerlIO_stdin(); + IoTYPE(io) = IoTYPE_STD; + } + else { + if (num_svs) { fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } else { - SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); - type = NULL; + SV *namesv = newSVpvn_flags(type, tend - type, SVs_TEMP); + type = NULL; fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,1,&namesv); - } - } - } + } + } + } } say_false: @@ -914,33 +914,33 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, Zero(&statbuf, 1, Stat_t); if (!fp) { - if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE) - && should_warn_nl(oname) - - ) + if (IoTYPE(io) == IoTYPE_RDONLY && ckWARN(WARN_NEWLINE) + && should_warn_nl(oname) + + ) { GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */ - Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); GCC_DIAG_RESTORE_STMT; } - goto say_false; + goto say_false; } if (ckWARN(WARN_IO)) { - if ((IoTYPE(io) == IoTYPE_RDONLY) && - (fp == PerlIO_stdout() || fp == PerlIO_stderr())) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle STD%s reopened as %" HEKf - " only for input", - ((fp == PerlIO_stdout()) ? "OUT" : "ERR"), - HEKfARG(GvENAME_HEK(gv))); - } - else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle STDIN reopened as %" HEKf " only for output", - HEKfARG(GvENAME_HEK(gv)) - ); - } + if ((IoTYPE(io) == IoTYPE_RDONLY) && + (fp == PerlIO_stdout() || fp == PerlIO_stderr())) { + Perl_warner(aTHX_ packWARN(WARN_IO), + "Filehandle STD%s reopened as %" HEKf + " only for input", + ((fp == PerlIO_stdout()) ? "OUT" : "ERR"), + HEKfARG(GvENAME_HEK(gv))); + } + else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdin()) { + Perl_warner(aTHX_ packWARN(WARN_IO), + "Filehandle STDIN reopened as %" HEKf " only for output", + HEKfARG(GvENAME_HEK(gv)) + ); + } } fd = PerlIO_fileno(fp); @@ -949,27 +949,27 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, * otherwise unless we "know" the type probe for socket-ness. */ if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) { - if (PerlLIO_fstat(fd,&statbuf) < 0) { - /* If PerlIO claims to have fd we had better be able to fstat() it. */ - (void) PerlIO_close(fp); - goto say_false; - } + if (PerlLIO_fstat(fd,&statbuf) < 0) { + /* If PerlIO claims to have fd we had better be able to fstat() it. */ + (void) PerlIO_close(fp); + goto say_false; + } #ifndef PERL_MICRO - if (S_ISSOCK(statbuf.st_mode)) - IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */ + if (S_ISSOCK(statbuf.st_mode)) + IoTYPE(io) = IoTYPE_SOCKET; /* in case a socket was passed in to us */ #ifdef HAS_SOCKET - else if ( - !(statbuf.st_mode & S_IFMT) - && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */ - && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */ - ) { /* on OS's that return 0 on fstat()ed pipe */ - char tmpbuf[256]; - Sock_size_t buflen = sizeof tmpbuf; - if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0 - || errno != ENOTSOCK) - IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */ - /* but some return 0 for streams too, sigh */ - } + else if ( + !(statbuf.st_mode & S_IFMT) + && IoTYPE(io) != IoTYPE_WRONLY /* Dups of STD* filehandles already have */ + && IoTYPE(io) != IoTYPE_RDONLY /* type so they aren't marked as sockets */ + ) { /* on OS's that return 0 on fstat()ed pipe */ + char tmpbuf[256]; + Sock_size_t buflen = sizeof tmpbuf; + if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0 + || errno != ENOTSOCK) + IoTYPE(io) = IoTYPE_SOCKET; /* some OS's return 0 on fstat()ed socket */ + /* but some return 0 for streams too, sigh */ + } #endif /* HAS_SOCKET */ #endif /* !PERL_MICRO */ } @@ -983,26 +983,26 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, /* If fd is less that PL_maxsysfd i.e. STDIN..STDERR then dup the new fileno down */ - if (saveofp) { - PerlIO_flush(saveofp); /* emulate PerlIO_close() */ - if (saveofp != saveifp) { /* was a socket? */ - PerlIO_close(saveofp); - } - } - if (savefd != fd) { - /* Still a small can-of-worms here if (say) PerlIO::scalar - is assigned to (say) STDOUT - for now let dup2() fail - and provide the error - */ - if (fd < 0) { + if (saveofp) { + PerlIO_flush(saveofp); /* emulate PerlIO_close() */ + if (saveofp != saveifp) { /* was a socket? */ + PerlIO_close(saveofp); + } + } + if (savefd != fd) { + /* Still a small can-of-worms here if (say) PerlIO::scalar + is assigned to (say) STDOUT - for now let dup2() fail + and provide the error + */ + if (fd < 0) { SETERRNO(EBADF,RMS_IFI); - goto say_false; + goto say_false; } else if (PerlLIO_dup2(fd, savefd) < 0) { - (void)PerlIO_close(fp); - goto say_false; - } + (void)PerlIO_close(fp); + goto say_false; + } #ifdef VMS - if (savefd != PerlIO_fileno(PerlIO_stdin())) { + if (savefd != PerlIO_fileno(PerlIO_stdin())) { char newname[FILENAME_MAX+1]; if (PerlIO_getname(fp, newname)) { if (fd == PerlIO_fileno(PerlIO_stdout())) @@ -1010,7 +1010,7 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, if (fd == PerlIO_fileno(PerlIO_stderr())) vmssetuserlnm("SYS$ERROR", newname); } - } + } #endif #if !defined(WIN32) @@ -1030,7 +1030,7 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, } #endif - if (was_fdopen) { + if (was_fdopen) { /* need to close fp without closing underlying fd */ int ofd = PerlIO_fileno(fp); int dupfd = ofd >= 0 ? PerlLIO_dup_cloexec(ofd) : -1; @@ -1043,31 +1043,31 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, PerlLIO_dup2_cloexec(dupfd, ofd); setfd_inhexec_for_sysfd(ofd); PerlLIO_close(dupfd); - } + } else - PerlIO_close(fp); - } - fp = saveifp; - PerlIO_clearerr(fp); - fd = PerlIO_fileno(fp); + PerlIO_close(fp); + } + fp = saveifp; + PerlIO_clearerr(fp); + fd = PerlIO_fileno(fp); } IoIFP(io) = fp; IoFLAGS(io) &= ~IOf_NOLINE; if (writing) { - if (IoTYPE(io) == IoTYPE_SOCKET - || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(statbuf.st_mode)) ) { - char *s = mode; - if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC) - s++; - *s = 'w'; - if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) { - PerlIO_close(fp); - goto say_false; - } - } - else - IoOFP(io) = fp; + if (IoTYPE(io) == IoTYPE_SOCKET + || (IoTYPE(io) == IoTYPE_WRONLY && fd >= 0 && S_ISCHR(statbuf.st_mode)) ) { + char *s = mode; + if (*s == IoTYPE_IMPLICIT || *s == IoTYPE_NUMERIC) + s++; + *s = 'w'; + if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,s,fd,0,0,NULL,0,NULL))) { + PerlIO_close(fp); + goto say_false; + } + } + else + IoOFP(io) = fp; } if (statbufp) *statbufp = statbuf; @@ -1291,14 +1291,14 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) SAVEFREESV(old_out_name); if (!PL_argvoutgv) - PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); + PL_argvoutgv = gv_fetchpvs("ARGVOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); if (io && (IoFLAGS(io) & (IOf_ARGV|IOf_START)) == (IOf_ARGV|IOf_START)) { - IoFLAGS(io) &= ~IOf_START; - if (PL_inplace) { - assert(PL_defoutgv); - Perl_av_create_and_push(aTHX_ &PL_argvout_stack, - SvREFCNT_inc_simple_NN(PL_defoutgv)); - } + IoFLAGS(io) &= ~IOf_START; + if (PL_inplace) { + assert(PL_defoutgv); + Perl_av_create_and_push(aTHX_ &PL_argvout_stack, + SvREFCNT_inc_simple_NN(PL_defoutgv)); + } } { @@ -1311,15 +1311,15 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) PL_lastfd = -1; PL_filemode = 0; if (!GvAV(gv)) - return NULL; + return NULL; while (av_count(GvAV(gv)) > 0) { - STRLEN oldlen; + STRLEN oldlen; SV *const sv = av_shift(GvAV(gv)); - SAVEFREESV(sv); - SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */ - sv_setsv(GvSVn(gv),sv); - SvSETMAGIC(GvSV(gv)); - PL_oldname = SvPVx(GvSV(gv), oldlen); + SAVEFREESV(sv); + SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */ + sv_setsv(GvSVn(gv),sv); + SvSETMAGIC(GvSV(gv)); + PL_oldname = SvPVx(GvSV(gv), oldlen); if (LIKELY(!PL_inplace)) { if (nomagicopen ? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1) @@ -1348,77 +1348,77 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) SV *temp_name_sv = NULL; MAGIC *mg; - TAINT_PROPER("inplace open"); - if (oldlen == 1 && *PL_oldname == '-') { - setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, - SVt_PVIO)); - return IoIFP(GvIOp(gv)); - } + TAINT_PROPER("inplace open"); + if (oldlen == 1 && *PL_oldname == '-') { + setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, + SVt_PVIO)); + return IoIFP(GvIOp(gv)); + } #ifndef FLEXFILENAMES - filedev = statbuf.st_dev; - fileino = statbuf.st_ino; -#endif - PL_filemode = statbuf.st_mode; - fileuid = statbuf.st_uid; - filegid = statbuf.st_gid; - if (!S_ISREG(PL_filemode)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), - "Can't do inplace edit: %s is not a regular file", - PL_oldname ); - do_close(gv,FALSE); - continue; - } + filedev = statbuf.st_dev; + fileino = statbuf.st_ino; +#endif + PL_filemode = statbuf.st_mode; + fileuid = statbuf.st_uid; + filegid = statbuf.st_gid; + if (!S_ISREG(PL_filemode)) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), + "Can't do inplace edit: %s is not a regular file", + PL_oldname ); + do_close(gv,FALSE); + continue; + } magic_av = newAV(); - if (*PL_inplace && strNE(PL_inplace, "*")) { - const char *star = strchr(PL_inplace, '*'); - if (star) { - const char *begin = PL_inplace; + if (*PL_inplace && strNE(PL_inplace, "*")) { + const char *star = strchr(PL_inplace, '*'); + if (star) { + const char *begin = PL_inplace; SvPVCLEAR(sv); - do { - sv_catpvn(sv, begin, star - begin); - sv_catpvn(sv, PL_oldname, oldlen); - begin = ++star; - } while ((star = strchr(begin, '*'))); - if (*begin) - sv_catpv(sv,begin); - } - else { - sv_catpv(sv,PL_inplace); - } + do { + sv_catpvn(sv, begin, star - begin); + sv_catpvn(sv, PL_oldname, oldlen); + begin = ++star; + } while ((star = strchr(begin, '*'))); + if (*begin) + sv_catpv(sv,begin); + } + else { + sv_catpv(sv,PL_inplace); + } #ifndef FLEXFILENAMES - if ((PerlLIO_stat(SvPVX_const(sv),&statbuf) >= 0 - && statbuf.st_dev == filedev - && statbuf.st_ino == fileino) + if ((PerlLIO_stat(SvPVX_const(sv),&statbuf) >= 0 + && statbuf.st_dev == filedev + && statbuf.st_ino == fileino) #ifdef DJGPP - || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0) + || ((_djstat_fail_bits & _STFAIL_TRUENAME)!=0) #endif ) - { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), - "Can't do inplace edit: %" + { + Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), + "Can't do inplace edit: %" SVf " would not be unique", - SVfARG(sv)); + SVfARG(sv)); goto cleanup_argv; - } + } #endif av_store(magic_av, ARGVMG_BACKUP_NAME, newSVsv(sv)); - } + } - sv_setpvn(sv,PL_oldname,oldlen); - SETERRNO(0,0); /* in case sprintf set errno */ + sv_setpvn(sv,PL_oldname,oldlen); + SETERRNO(0,0); /* in case sprintf set errno */ temp_name_sv = newSV(0); if (!S_openindirtemp(aTHX_ PL_argvoutgv, GvSV(gv), temp_name_sv)) { SvREFCNT_dec(temp_name_sv); /* diag_listed_as: Can't do inplace edit on %s: %s */ Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: Cannot make temp name: %s", - PL_oldname, Strerror(errno) ); + PL_oldname, Strerror(errno) ); #ifndef FLEXFILENAMES cleanup_argv: #endif do_close(gv,FALSE); SvREFCNT_dec(magic_av); continue; - } + } av_store(magic_av, ARGVMG_TEMP_NAME, temp_name_sv); av_store(magic_av, ARGVMG_ORIG_NAME, newSVsv(sv)); av_store(magic_av, ARGVMG_ORIG_MODE, newSVuv(PL_filemode)); @@ -1432,12 +1432,12 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) newSVpvn((char *)&statbuf, sizeof(statbuf))); } #endif - setdefout(PL_argvoutgv); + setdefout(PL_argvoutgv); sv_setsv(GvSVn(PL_argvoutgv), temp_name_sv); mg = sv_magicext((SV*)GvIOp(PL_argvoutgv), (SV*)magic_av, PERL_MAGIC_uvar, &argvout_vtbl, NULL, 0); mg->mg_flags |= MGf_DUP; SvREFCNT_dec(magic_av); - PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); + PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); if (PL_lastfd >= 0) { (void)PerlLIO_fstat(PL_lastfd,&statbuf); #ifdef HAS_FCHMOD @@ -1453,10 +1453,10 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) PERL_UNUSED_RESULT(PerlLIO_chown(PL_oldname,fileuid,filegid)); #endif } - } + } return IoIFP(GvIOp(gv)); - } - } /* successful do_open_raw(), PL_inplace non-NULL */ + } + } /* successful do_open_raw(), PL_inplace non-NULL */ if (ckWARN_d(WARN_INPLACE)) { const int eno = errno; @@ -1471,20 +1471,20 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't open %s: %s", PL_oldname, Strerror(eno)); } - } + } } if (io && (IoFLAGS(io) & IOf_ARGV)) - IoFLAGS(io) |= IOf_START; + IoFLAGS(io) |= IOf_START; if (PL_inplace) { - if (io && (IoFLAGS(io) & IOf_ARGV) - && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0) - { - GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack)); - setdefout(oldout); - SvREFCNT_dec_NN(oldout); - return NULL; - } - setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO)); + if (io && (IoFLAGS(io) & IOf_ARGV) + && PL_argvout_stack && AvFILLp(PL_argvout_stack) >= 0) + { + GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack)); + setdefout(oldout); + SvREFCNT_dec_NN(oldout); + return NULL; + } + setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO)); } return NULL; } @@ -1687,7 +1687,7 @@ S_argvout_final(pTHX_ MAGIC *mg, IO *io, bool not_implicit) { #if !defined(HAS_RENAME) link(SvPVX(*temp_psv), orig_pv) < 0 #elif defined(ARGV_USE_ATFUNCTIONS) - S_my_renameat(dfd, SvPVX(*temp_psv), dfd, orig_pv) < 0 && + S_my_renameat(dfd, SvPVX(*temp_psv), dfd, orig_pv) < 0 && !(UNLIKELY(NotSupported(errno)) && dir_unchanged(orig_pv, mg) && PerlLIO_rename(SvPVX(*temp_psv), orig_pv) == 0) @@ -1744,19 +1744,19 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) MAGIC *mg; if (!gv) - gv = PL_argvgv; + gv = PL_argvgv; if (!gv || !isGV_with_GP(gv)) { - if (not_implicit) - SETERRNO(EBADF,SS_IVCHAN); - return FALSE; + if (not_implicit) + SETERRNO(EBADF,SS_IVCHAN); + return FALSE; } io = GvIO(gv); if (!io) { /* never opened */ - if (not_implicit) { - report_evil_fh(gv); - SETERRNO(EBADF,SS_IVCHAN); - } - return FALSE; + if (not_implicit) { + report_evil_fh(gv); + SETERRNO(EBADF,SS_IVCHAN); + } + return FALSE; } if ((mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl)) && mg->mg_obj) { @@ -1767,9 +1767,9 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) retval = io_close(io, NULL, not_implicit, FALSE); } if (not_implicit) { - IoLINES(io) = 0; - IoPAGE(io) = 0; - IoLINES_LEFT(io) = IoPAGE_LEN(io); + IoLINES(io) = 0; + IoPAGE(io) = 0; + IoLINES_LEFT(io) = IoPAGE_LEN(io); } IoTYPE(io) = IoTYPE_CLOSED; return retval; @@ -1783,7 +1783,7 @@ Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail) PERL_ARGS_ASSERT_IO_CLOSE; if (IoIFP(io)) { - if (IoTYPE(io) == IoTYPE_PIPE) { + if (IoTYPE(io) == IoTYPE_PIPE) { PerlIO *fh = IoIFP(io); int status; @@ -1794,54 +1794,54 @@ Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail) So NULL it early. */ IoOFP(io) = IoIFP(io) = NULL; - status = PerlProc_pclose(fh); - if (not_implicit) { - STATUS_NATIVE_CHILD_SET(status); - retval = (STATUS_UNIX == 0); - } - else { - retval = (status != -1); - } - } - else if (IoTYPE(io) == IoTYPE_STD) - retval = TRUE; - else { - if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ - const bool prev_err = PerlIO_error(IoOFP(io)); + status = PerlProc_pclose(fh); + if (not_implicit) { + STATUS_NATIVE_CHILD_SET(status); + retval = (STATUS_UNIX == 0); + } + else { + retval = (status != -1); + } + } + else if (IoTYPE(io) == IoTYPE_STD) + retval = TRUE; + else { + if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ + const bool prev_err = PerlIO_error(IoOFP(io)); #ifdef USE_PERLIO - if (prev_err) - PerlIO_restore_errno(IoOFP(io)); -#endif - retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err); - PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ - } - else { - const bool prev_err = PerlIO_error(IoIFP(io)); + if (prev_err) + PerlIO_restore_errno(IoOFP(io)); +#endif + retval = (PerlIO_close(IoOFP(io)) != EOF && !prev_err); + PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ + } + else { + const bool prev_err = PerlIO_error(IoIFP(io)); #ifdef USE_PERLIO - if (prev_err) - PerlIO_restore_errno(IoIFP(io)); -#endif - retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err); - } - } - IoOFP(io) = IoIFP(io) = NULL; - - if (warn_on_fail && !retval) { - if (gv) - Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), - "Warning: unable to close filehandle %" - HEKf " properly: %" SVf, - HEKfARG(GvNAME_HEK(gv)), + if (prev_err) + PerlIO_restore_errno(IoIFP(io)); +#endif + retval = (PerlIO_close(IoIFP(io)) != EOF && !prev_err); + } + } + IoOFP(io) = IoIFP(io) = NULL; + + if (warn_on_fail && !retval) { + if (gv) + Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), + "Warning: unable to close filehandle %" + HEKf " properly: %" SVf, + HEKfARG(GvNAME_HEK(gv)), SVfARG(get_sv("!",GV_ADD))); - else - Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), - "Warning: unable to close filehandle " - "properly: %" SVf, - SVfARG(get_sv("!",GV_ADD))); - } + else + Perl_ck_warner_d(aTHX_ packWARN(WARN_IO), + "Warning: unable to close filehandle " + "properly: %" SVf, + SVfARG(get_sv("!",GV_ADD))); + } } else if (not_implicit) { - SETERRNO(EBADF,SS_IVCHAN); + SETERRNO(EBADF,SS_IVCHAN); } return retval; @@ -1855,38 +1855,38 @@ Perl_do_eof(pTHX_ GV *gv) PERL_ARGS_ASSERT_DO_EOF; if (!io) - return TRUE; + return TRUE; else if (IoTYPE(io) == IoTYPE_WRONLY) - report_wrongway_fh(gv, '>'); + report_wrongway_fh(gv, '>'); while (IoIFP(io)) { if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */ - if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ - return FALSE; /* this is the most usual case */ - } - - { - /* getc and ungetc can stomp on errno */ - dSAVE_ERRNO; - const int ch = PerlIO_getc(IoIFP(io)); - if (ch != EOF) { - (void)PerlIO_ungetc(IoIFP(io),ch); - RESTORE_ERRNO; - return FALSE; - } - RESTORE_ERRNO; - } + if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ + return FALSE; /* this is the most usual case */ + } + + { + /* getc and ungetc can stomp on errno */ + dSAVE_ERRNO; + const int ch = PerlIO_getc(IoIFP(io)); + if (ch != EOF) { + (void)PerlIO_ungetc(IoIFP(io),ch); + RESTORE_ERRNO; + return FALSE; + } + RESTORE_ERRNO; + } if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { - if (PerlIO_get_cnt(IoIFP(io)) < -1) - PerlIO_set_cnt(IoIFP(io),-1); - } - if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ - if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */ - return TRUE; - } - else - return TRUE; /* normal fp, definitely end of file */ + if (PerlIO_get_cnt(IoIFP(io)) < -1) + PerlIO_set_cnt(IoIFP(io),-1); + } + if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ + if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */ + return TRUE; + } + else + return TRUE; /* normal fp, definitely end of file */ } return TRUE; } @@ -1900,7 +1900,7 @@ Perl_do_tell(pTHX_ GV *gv) PERL_ARGS_ASSERT_DO_TELL; if (io && (fp = IoIFP(io))) { - return PerlIO_tell(fp); + return PerlIO_tell(fp); } report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); @@ -1914,7 +1914,7 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) PerlIO *fp; if (io && (fp = IoIFP(io))) { - return PerlIO_seek(fp, pos, whence) >= 0; + return PerlIO_seek(fp, pos, whence) >= 0; } report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); @@ -1949,51 +1949,51 @@ Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len) int mode = O_BINARY; PERL_UNUSED_CONTEXT; if (s) { - while (*s) { - if (*s == ':') { - switch (s[1]) { - case 'r': - if (s[2] == 'a' && s[3] == 'w' - && (!s[4] || s[4] == ':' || isSPACE(s[4]))) - { - mode = O_BINARY; - s += 4; - len -= 4; - break; - } - /* FALLTHROUGH */ - case 'c': - if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f' - && (!s[5] || s[5] == ':' || isSPACE(s[5]))) - { - mode = O_TEXT; - s += 5; - len -= 5; - break; - } - /* FALLTHROUGH */ - default: - goto fail_discipline; - } - } - else if (isSPACE(*s)) { - ++s; - --len; - } - else { - const char *end; + while (*s) { + if (*s == ':') { + switch (s[1]) { + case 'r': + if (s[2] == 'a' && s[3] == 'w' + && (!s[4] || s[4] == ':' || isSPACE(s[4]))) + { + mode = O_BINARY; + s += 4; + len -= 4; + break; + } + /* FALLTHROUGH */ + case 'c': + if (s[2] == 'r' && s[3] == 'l' && s[4] == 'f' + && (!s[5] || s[5] == ':' || isSPACE(s[5]))) + { + mode = O_TEXT; + s += 5; + len -= 5; + break; + } + /* FALLTHROUGH */ + default: + goto fail_discipline; + } + } + else if (isSPACE(*s)) { + ++s; + --len; + } + else { + const char *end; fail_discipline: - end = (char *) memchr(s+1, ':', len); - if (!end) - end = s+len; + end = (char *) memchr(s+1, ':', len); + if (!end) + end = s+len; #ifndef PERLIO_LAYERS - Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s); + Perl_croak(aTHX_ "IO layers (like '%.*s') unavailable", end-s, s); #else - len -= end-s; - s = end; + len -= end-s; + s = end; #endif - } - } + } + } } return mode; } @@ -2003,44 +2003,44 @@ I32 my_chsize(int fd, Off_t length) { #ifdef F_FREESP - /* code courtesy of William Kucharski */ + /* code courtesy of William Kucharski */ #define HAS_CHSIZE Stat_t filebuf; if (PerlLIO_fstat(fd, &filebuf) < 0) - return -1; + return -1; if (filebuf.st_size < length) { - /* extend file length */ + /* extend file length */ - if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0) - return -1; + if ((PerlLIO_lseek(fd, (length - 1), 0)) < 0) + return -1; - /* write a "0" byte */ + /* write a "0" byte */ - if ((PerlLIO_write(fd, "", 1)) != 1) - return -1; + if ((PerlLIO_write(fd, "", 1)) != 1) + return -1; } else { - /* truncate length */ - struct flock fl; - fl.l_whence = 0; - fl.l_len = 0; - fl.l_start = length; - fl.l_type = F_WRLCK; /* write lock on file space */ - - /* - * This relies on the UNDOCUMENTED F_FREESP argument to - * fcntl(2), which truncates the file so that it ends at the - * position indicated by fl.l_start. - * - * Will minor miracles never cease? - */ + /* truncate length */ + struct flock fl; + fl.l_whence = 0; + fl.l_len = 0; + fl.l_start = length; + fl.l_type = F_WRLCK; /* write lock on file space */ + + /* + * This relies on the UNDOCUMENTED F_FREESP argument to + * fcntl(2), which truncates the file so that it ends at the + * position indicated by fl.l_start. + * + * Will minor miracles never cease? + */ - if (fcntl(fd, F_FREESP, &fl) < 0) - return -1; + if (fcntl(fd, F_FREESP, &fl) < 0) + return -1; } return 0; @@ -2058,67 +2058,67 @@ Perl_do_print(pTHX_ SV *sv, PerlIO *fp) /* assuming fp is checked earlier */ if (!sv) - return TRUE; + return TRUE; if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) { - assert(!SvGMAGICAL(sv)); - if (SvIsUV(sv)) - PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv)); - else - PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv)); - return !PerlIO_error(fp); + assert(!SvGMAGICAL(sv)); + if (SvIsUV(sv)) + PerlIO_printf(fp, "%" UVuf, (UV)SvUVX(sv)); + else + PerlIO_printf(fp, "%" IVdf, (IV)SvIVX(sv)); + return !PerlIO_error(fp); } else { - STRLEN len; - /* Do this first to trigger any overloading. */ - const char *tmps = SvPV_const(sv, len); - U8 *tmpbuf = NULL; - bool happy = TRUE; - - if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */ - if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */ - /* We don't modify the original scalar. */ - tmpbuf = bytes_to_utf8((const U8*) tmps, &len); - tmps = (char *) tmpbuf; - } - else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) { - (void) check_utf8_print((const U8*) tmps, len); - } - } /* else stream isn't utf8 */ - else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to - convert to bytes */ - STRLEN tmplen = len; - bool utf8 = TRUE; - U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8); - if (!utf8) { - - /* Here, succeeded in downgrading from utf8. Set up to below - * output the converted value */ - tmpbuf = result; - tmps = (char *) tmpbuf; - len = tmplen; - } - else { /* Non-utf8 output stream, but string only representable in - utf8 */ - assert((char *)result == tmps); - Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), - "Wide character in %s", - PL_op ? OP_DESC(PL_op) : "print" - ); - /* Could also check that isn't one of the things to avoid - * in utf8 by using check_utf8_print(), but not doing so, - * since the stream isn't a UTF8 stream */ - } - } - /* To detect whether the process is about to overstep its - * filesize limit we would need getrlimit(). We could then - * also transparently raise the limit with setrlimit() -- - * but only until the system hard limit/the filesystem limit, - * at which we would get EPERM. Note that when using buffered - * io the write failure can be delayed until the flush/close. --jhi */ - if (len && (PerlIO_write(fp,tmps,len) == 0)) - happy = FALSE; - Safefree(tmpbuf); - return happy ? !PerlIO_error(fp) : FALSE; + STRLEN len; + /* Do this first to trigger any overloading. */ + const char *tmps = SvPV_const(sv, len); + U8 *tmpbuf = NULL; + bool happy = TRUE; + + if (PerlIO_isutf8(fp)) { /* If the stream is utf8 ... */ + if (!SvUTF8(sv)) { /* Convert to utf8 if necessary */ + /* We don't modify the original scalar. */ + tmpbuf = bytes_to_utf8((const U8*) tmps, &len); + tmps = (char *) tmpbuf; + } + else if (ckWARN4_d(WARN_UTF8, WARN_SURROGATE, WARN_NON_UNICODE, WARN_NONCHAR)) { + (void) check_utf8_print((const U8*) tmps, len); + } + } /* else stream isn't utf8 */ + else if (DO_UTF8(sv)) { /* But if is utf8 internally, attempt to + convert to bytes */ + STRLEN tmplen = len; + bool utf8 = TRUE; + U8 * const result = bytes_from_utf8((const U8*) tmps, &tmplen, &utf8); + if (!utf8) { + + /* Here, succeeded in downgrading from utf8. Set up to below + * output the converted value */ + tmpbuf = result; + tmps = (char *) tmpbuf; + len = tmplen; + } + else { /* Non-utf8 output stream, but string only representable in + utf8 */ + assert((char *)result == tmps); + Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), + "Wide character in %s", + PL_op ? OP_DESC(PL_op) : "print" + ); + /* Could also check that isn't one of the things to avoid + * in utf8 by using check_utf8_print(), but not doing so, + * since the stream isn't a UTF8 stream */ + } + } + /* To detect whether the process is about to overstep its + * filesize limit we would need getrlimit(). We could then + * also transparently raise the limit with setrlimit() -- + * but only until the system hard limit/the filesystem limit, + * at which we would get EPERM. Note that when using buffered + * io the write failure can be delayed until the flush/close. --jhi */ + if (len && (PerlIO_write(fp,tmps,len) == 0)) + happy = FALSE; + Safefree(tmpbuf); + return happy ? !PerlIO_error(fp) : FALSE; } } @@ -2130,24 +2130,24 @@ Perl_my_stat_flags(pTHX_ const U32 flags) GV* gv; if (PL_op->op_flags & OPf_REF) { - gv = cGVOP_gv; + gv = cGVOP_gv; do_fstat: if (gv == PL_defgv) { - if (PL_laststatval < 0) - SETERRNO(EBADF,RMS_IFI); + if (PL_laststatval < 0) + SETERRNO(EBADF,RMS_IFI); return PL_laststatval; - } - io = GvIO(gv); + } + io = GvIO(gv); do_fstat_have_io: PL_laststype = OP_STAT; PL_statgv = gv ? gv : (GV *)io; SvPVCLEAR(PL_statname); if (io) { - if (IoIFP(io)) { + if (IoIFP(io)) { int fd = PerlIO_fileno(IoIFP(io)); if (fd < 0) { /* E.g. PerlIO::scalar has no real fd. */ - SETERRNO(EBADF,RMS_IFI); + SETERRNO(EBADF,RMS_IFI); return (PL_laststatval = -1); } else { return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache)); @@ -2156,44 +2156,44 @@ Perl_my_stat_flags(pTHX_ const U32 flags) return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache)); } } - PL_laststatval = -1; - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); - return -1; + PL_laststatval = -1; + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + return -1; } else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) - == OPpFT_STACKED) - return PL_laststatval; + == OPpFT_STACKED) + return PL_laststatval; else { - SV* const sv = TOPs; - const char *s, *d; - STRLEN len; - if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) { - goto do_fstat; - } + SV* const sv = TOPs; + const char *s, *d; + STRLEN len; + if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) { + goto do_fstat; + } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { io = MUTABLE_IO(SvRV(sv)); - gv = NULL; + gv = NULL; goto do_fstat_have_io; } - s = SvPV_flags_const(sv, len, flags); - PL_statgv = NULL; - sv_setpvn(PL_statname, s, len); - d = SvPVX_const(PL_statname); /* s now NUL-terminated */ - PL_laststype = OP_STAT; + s = SvPV_flags_const(sv, len, flags); + PL_statgv = NULL; + sv_setpvn(PL_statname, s, len); + d = SvPVX_const(PL_statname); /* s now NUL-terminated */ + PL_laststype = OP_STAT; if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) { PL_laststatval = -1; } else { PL_laststatval = PerlLIO_stat(d, &PL_statcache); } - if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) { + if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) { GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* PL_warn_nl is constant */ - Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); GCC_DIAG_RESTORE_STMT; } - return PL_laststatval; + return PL_laststatval; } } @@ -2208,27 +2208,27 @@ Perl_my_lstat_flags(pTHX_ const U32 flags) SV* const sv = TOPs; bool isio = FALSE; if (PL_op->op_flags & OPf_REF) { - if (cGVOP_gv == PL_defgv) { - if (PL_laststype != OP_LSTAT) - Perl_croak(aTHX_ "%s", no_prev_lstat); - if (PL_laststatval < 0) - SETERRNO(EBADF,RMS_IFI); - return PL_laststatval; - } - PL_laststatval = -1; - if (ckWARN(WARN_IO)) { - /* diag_listed_as: Use of -l on filehandle%s */ - Perl_warner(aTHX_ packWARN(WARN_IO), - "Use of -l on filehandle %" HEKf, - HEKfARG(GvENAME_HEK(cGVOP_gv))); - } - SETERRNO(EBADF,RMS_IFI); - return -1; + if (cGVOP_gv == PL_defgv) { + if (PL_laststype != OP_LSTAT) + Perl_croak(aTHX_ "%s", no_prev_lstat); + if (PL_laststatval < 0) + SETERRNO(EBADF,RMS_IFI); + return PL_laststatval; + } + PL_laststatval = -1; + if (ckWARN(WARN_IO)) { + /* diag_listed_as: Use of -l on filehandle%s */ + Perl_warner(aTHX_ packWARN(WARN_IO), + "Use of -l on filehandle %" HEKf, + HEKfARG(GvENAME_HEK(cGVOP_gv))); + } + SETERRNO(EBADF,RMS_IFI); + return -1; } if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) - == OPpFT_STACKED) { + == OPpFT_STACKED) { if (PL_laststype != OP_LSTAT) - Perl_croak(aTHX_ "%s", no_prev_lstat); + Perl_croak(aTHX_ "%s", no_prev_lstat); return PL_laststatval; } @@ -2241,11 +2241,11 @@ Perl_my_lstat_flags(pTHX_ const U32 flags) ) && ckWARN(WARN_IO)) { if (isio) - /* diag_listed_as: Use of -l on filehandle%s */ + /* diag_listed_as: Use of -l on filehandle%s */ Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle"); else - /* diag_listed_as: Use of -l on filehandle%s */ + /* diag_listed_as: Use of -l on filehandle%s */ Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %" HEKf, HEKfARG(GvENAME_HEK((const GV *) @@ -2279,13 +2279,13 @@ S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) if (do_report) { /* XXX silently ignore failures */ PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int))); - PerlLIO_close(fd); + PerlLIO_close(fd); } } bool Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp, - int fd, int do_report) + int fd, int do_report) { PERL_ARGS_ASSERT_DO_AEXEC5; #if defined(__LIBCATAMOUNT__) @@ -2294,37 +2294,37 @@ Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp, assert(sp >= mark); ENTER; { - const char **argv, **a; - const char *tmps = NULL; - Newx(argv, sp - mark + 1, const char*); - SAVEFREEPV(argv); - a = argv; - - while (++mark <= sp) { - if (*mark) { - char *arg = savepv(SvPV_nolen_const(*mark)); - SAVEFREEPV(arg); - *a++ = arg; - } else - *a++ = ""; - } - *a = NULL; - if (really) { - tmps = savepv(SvPV_nolen_const(really)); - SAVEFREEPV(tmps); - } + const char **argv, **a; + const char *tmps = NULL; + Newx(argv, sp - mark + 1, const char*); + SAVEFREEPV(argv); + a = argv; + + while (++mark <= sp) { + if (*mark) { + char *arg = savepv(SvPV_nolen_const(*mark)); + SAVEFREEPV(arg); + *a++ = arg; + } else + *a++ = ""; + } + *a = NULL; + if (really) { + tmps = savepv(SvPV_nolen_const(really)); + SAVEFREEPV(tmps); + } if ((!really && argv[0] && *argv[0] != '/') || - (really && *tmps != '/')) /* will execvp use PATH? */ - TAINT_ENV(); /* testing IFS here is overkill, probably */ - PERL_FPU_PRE_EXEC - if (really && *tmps) { + (really && *tmps != '/')) /* will execvp use PATH? */ + TAINT_ENV(); /* testing IFS here is overkill, probably */ + PERL_FPU_PRE_EXEC + if (really && *tmps) { PerlProc_execvp(tmps,EXEC_ARGV_CAST(argv)); } else if (argv[0]) { PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv)); } else { SETERRNO(ENOENT,RMS_FNF); } - PERL_FPU_POST_EXEC + PERL_FPU_POST_EXEC S_exec_failed(aTHX_ (really ? tmps : argv[0] ? argv[0] : ""), fd, do_report); } LEAVE; @@ -2353,86 +2353,86 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) memcpy(cmd, incmd, cmdlen); while (*cmd && isSPACE(*cmd)) - cmd++; + cmd++; /* save an extra exec if possible */ #ifdef CSH { char flags[PERL_FLAGS_MAX]; - if (strnEQ(cmd,PL_cshname,PL_cshlen) && - strBEGINs(cmd+PL_cshlen," -c")) { + if (strnEQ(cmd,PL_cshname,PL_cshlen) && + strBEGINs(cmd+PL_cshlen," -c")) { my_strlcpy(flags, "-c", PERL_FLAGS_MAX); - s = cmd+PL_cshlen+3; - if (*s == 'f') { - s++; + s = cmd+PL_cshlen+3; + if (*s == 'f') { + s++; my_strlcat(flags, "f", PERL_FLAGS_MAX - 2); - } - if (*s == ' ') - s++; - if (*s++ == '\'') { - char * const ncmd = s; - - while (*s) - s++; - if (s[-1] == '\n') - *--s = '\0'; - if (s[-1] == '\'') { - *--s = '\0'; - PERL_FPU_PRE_EXEC - PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL); - PERL_FPU_POST_EXEC - *s = '\''; - S_exec_failed(aTHX_ PL_cshname, fd, do_report); - goto leave; - } - } - } + } + if (*s == ' ') + s++; + if (*s++ == '\'') { + char * const ncmd = s; + + while (*s) + s++; + if (s[-1] == '\n') + *--s = '\0'; + if (s[-1] == '\'') { + *--s = '\0'; + PERL_FPU_PRE_EXEC + PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL); + PERL_FPU_POST_EXEC + *s = '\''; + S_exec_failed(aTHX_ PL_cshname, fd, do_report); + goto leave; + } + } + } } #endif /* CSH */ /* see if there are shell metacharacters in it */ if (*cmd == '.' && isSPACE(cmd[1])) - goto doshell; + goto doshell; if (strBEGINs(cmd,"exec") && isSPACE(cmd[4])) - goto doshell; + goto doshell; s = cmd; while (isWORDCHAR(*s)) - s++; /* catch VAR=val gizmo */ + s++; /* catch VAR=val gizmo */ if (*s == '=') - goto doshell; + goto doshell; for (s = cmd; *s; s++) { - if (*s != ' ' && !isALPHA(*s) && - memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) { - if (*s == '\n' && !s[1]) { - *s = '\0'; - break; - } - /* handle the 2>&1 construct at the end */ - if (*s == '>' && s[1] == '&' && s[2] == '1' - && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) - && (!s[3] || isSPACE(s[3]))) - { + if (*s != ' ' && !isALPHA(*s) && + memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) { + if (*s == '\n' && !s[1]) { + *s = '\0'; + break; + } + /* handle the 2>&1 construct at the end */ + if (*s == '>' && s[1] == '&' && s[2] == '1' + && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2]) + && (!s[3] || isSPACE(s[3]))) + { const char *t = s + 3; - while (*t && isSPACE(*t)) - ++t; - if (!*t && (PerlLIO_dup2(1,2) != -1)) { - s[-2] = '\0'; - break; - } - } - doshell: - PERL_FPU_PRE_EXEC + while (*t && isSPACE(*t)) + ++t; + if (!*t && (PerlLIO_dup2(1,2) != -1)) { + s[-2] = '\0'; + break; + } + } + doshell: + PERL_FPU_PRE_EXEC PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL); - PERL_FPU_POST_EXEC - S_exec_failed(aTHX_ PL_sh_path, fd, do_report); - goto leave; - } + PERL_FPU_POST_EXEC + S_exec_failed(aTHX_ PL_sh_path, fd, do_report); + goto leave; + } } Newx(argv, (s - cmd) / 2 + 2, const char*); @@ -2441,23 +2441,23 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) SAVEFREEPV(cmd); a = argv; for (s = cmd; *s;) { - while (isSPACE(*s)) - s++; - if (*s) - *(a++) = s; - while (*s && !isSPACE(*s)) - s++; - if (*s) - *s++ = '\0'; + while (isSPACE(*s)) + s++; + if (*s) + *(a++) = s; + while (*s && !isSPACE(*s)) + s++; + if (*s) + *s++ = '\0'; } *a = NULL; if (argv[0]) { - PERL_FPU_PRE_EXEC + PERL_FPU_PRE_EXEC PerlProc_execvp(argv[0],EXEC_ARGV_CAST(argv)); - PERL_FPU_POST_EXEC - if (errno == ENOEXEC) /* for system V NIH syndrome */ - goto doshell; - S_exec_failed(aTHX_ argv[0], fd, do_report); + PERL_FPU_POST_EXEC + if (errno == ENOEXEC) /* for system V NIH syndrome */ + goto doshell; + S_exec_failed(aTHX_ argv[0], fd, do_report); } leave: LEAVE; @@ -2486,109 +2486,109 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp) platforms where kill was not defined. */ #ifndef HAS_KILL if (type == OP_KILL) - Perl_die(aTHX_ PL_no_func, what); + Perl_die(aTHX_ PL_no_func, what); #endif #ifndef HAS_CHOWN if (type == OP_CHOWN) - Perl_die(aTHX_ PL_no_func, what); + Perl_die(aTHX_ PL_no_func, what); #endif #define APPLY_TAINT_PROPER() \ STMT_START { \ - if (TAINT_get) { TAINT_PROPER(what); } \ + if (TAINT_get) { TAINT_PROPER(what); } \ } STMT_END /* This is a first heuristic; it doesn't catch tainting magic. */ if (TAINTING_get) { - while (++mark <= sp) { - if (SvTAINTED(*mark)) { - TAINT; - break; - } - } - mark = oldmark; + while (++mark <= sp) { + if (SvTAINTED(*mark)) { + TAINT; + break; + } + } + mark = oldmark; } switch (type) { case OP_CHMOD: - APPLY_TAINT_PROPER(); - if (++mark <= sp) { - val = SvIV(*mark); - APPLY_TAINT_PROPER(); - tot = sp - mark; - while (++mark <= sp) { + APPLY_TAINT_PROPER(); + if (++mark <= sp) { + val = SvIV(*mark); + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { GV* gv; if ((gv = MAYBE_DEREF_GV(*mark))) { - if (GvIO(gv) && IoIFP(GvIOp(gv))) { + if (GvIO(gv) && IoIFP(GvIOp(gv))) { #ifdef HAS_FCHMOD int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); - APPLY_TAINT_PROPER(); + APPLY_TAINT_PROPER(); if (fd < 0) { SETERRNO(EBADF,RMS_IFI); tot--; } else if (fchmod(fd, val)) tot--; #else - Perl_die(aTHX_ PL_no_func, "fchmod"); + Perl_die(aTHX_ PL_no_func, "fchmod"); #endif - } - else { + } + else { SETERRNO(EBADF,RMS_IFI); - tot--; - } - } - else { - const char *name = SvPV_nomg_const(*mark, len); - APPLY_TAINT_PROPER(); + tot--; + } + } + else { + const char *name = SvPV_nomg_const(*mark, len); + APPLY_TAINT_PROPER(); if (!IS_SAFE_PATHNAME(name, len, "chmod") || PerlLIO_chmod(name, val)) { tot--; } - } - } - } - break; + } + } + } + break; #ifdef HAS_CHOWN case OP_CHOWN: - APPLY_TAINT_PROPER(); - if (sp - mark > 2) { + APPLY_TAINT_PROPER(); + if (sp - mark > 2) { I32 val2; - val = SvIVx(*++mark); - val2 = SvIVx(*++mark); - APPLY_TAINT_PROPER(); - tot = sp - mark; - while (++mark <= sp) { + val = SvIVx(*++mark); + val2 = SvIVx(*++mark); + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { GV* gv; - if ((gv = MAYBE_DEREF_GV(*mark))) { - if (GvIO(gv) && IoIFP(GvIOp(gv))) { + if ((gv = MAYBE_DEREF_GV(*mark))) { + if (GvIO(gv) && IoIFP(GvIOp(gv))) { #ifdef HAS_FCHOWN int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); - APPLY_TAINT_PROPER(); + APPLY_TAINT_PROPER(); if (fd < 0) { SETERRNO(EBADF,RMS_IFI); - tot--; + tot--; } else if (fchown(fd, val, val2)) - tot--; + tot--; #else - Perl_die(aTHX_ PL_no_func, "fchown"); + Perl_die(aTHX_ PL_no_func, "fchown"); #endif - } - else { + } + else { SETERRNO(EBADF,RMS_IFI); - tot--; - } - } - else { - const char *name = SvPV_nomg_const(*mark, len); - APPLY_TAINT_PROPER(); + tot--; + } + } + else { + const char *name = SvPV_nomg_const(*mark, len); + APPLY_TAINT_PROPER(); if (!IS_SAFE_PATHNAME(name, len, "chown") || PerlLIO_chown(name, val, val2)) { - tot--; + tot--; } - } - } - } - break; + } + } + } + break; #endif /* XXX Should we make lchown() directly available from perl? @@ -2598,44 +2598,44 @@ nothing in the core. */ #ifdef HAS_KILL case OP_KILL: - APPLY_TAINT_PROPER(); - if (mark == sp) - break; - s = SvPVx_const(*++mark, len); - if (*s == '-' && isALPHA(s[1])) - { - s++; - len--; + APPLY_TAINT_PROPER(); + if (mark == sp) + break; + s = SvPVx_const(*++mark, len); + if (*s == '-' && isALPHA(s[1])) + { + s++; + len--; killgp = TRUE; - } - if (isALPHA(*s)) { - if (*s == 'S' && s[1] == 'I' && s[2] == 'G') { - s += 3; + } + if (isALPHA(*s)) { + if (*s == 'S' && s[1] == 'I' && s[2] == 'G') { + s += 3; len -= 3; } if ((val = whichsig_pvn(s, len)) < 0) Perl_croak(aTHX_ "Unrecognized signal name \"%" SVf "\"", SVfARG(*mark)); - } - else - { - val = SvIV(*mark); - if (val < 0) - { - killgp = TRUE; + } + else + { + val = SvIV(*mark); + if (val < 0) + { + killgp = TRUE; val = -val; - } - } - APPLY_TAINT_PROPER(); - tot = sp - mark; - - while (++mark <= sp) { - Pid_t proc; - SvGETMAGIC(*mark); - if (!(SvNIOK(*mark) || looks_like_number(*mark))) - Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); - proc = SvIV_nomg(*mark); - APPLY_TAINT_PROPER(); + } + } + APPLY_TAINT_PROPER(); + tot = sp - mark; + + while (++mark <= sp) { + Pid_t proc; + SvGETMAGIC(*mark); + if (!(SvNIOK(*mark) || looks_like_number(*mark))) + Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); + proc = SvIV_nomg(*mark); + APPLY_TAINT_PROPER(); #ifdef HAS_KILLPG /* use killpg in preference, as the killpg() wrapper for Win32 * understands process groups, but the kill() wrapper doesn't */ @@ -2644,28 +2644,28 @@ nothing in the core. #else if (PerlProc_kill(killgp ? -proc: proc, val)) #endif - tot--; - } - PERL_ASYNC_CHECK(); - break; + tot--; + } + PERL_ASYNC_CHECK(); + break; #endif case OP_UNLINK: - APPLY_TAINT_PROPER(); - tot = sp - mark; - while (++mark <= sp) { - s = SvPV_const(*mark, len); - APPLY_TAINT_PROPER(); - if (!IS_SAFE_PATHNAME(s, len, "unlink")) { + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { + s = SvPV_const(*mark, len); + APPLY_TAINT_PROPER(); + if (!IS_SAFE_PATHNAME(s, len, "unlink")) { tot--; } - else if (PL_unsafe) { - if (UNLINK(s)) - { - tot--; - } + else if (PL_unsafe) { + if (UNLINK(s)) + { + tot--; + } #if defined(__amigaos4__) && defined(NEWLIB) - else - { + else + { /* Under AmigaOS4 unlink only 'fails' if the * filename is invalid. It may not remove the file * if it's locked, so check if it's still around. */ @@ -2673,58 +2673,58 @@ nothing in the core. { tot--; } - } -#endif - } - else { /* don't let root wipe out directories without -U */ - Stat_t statbuf; - if (PerlLIO_lstat(s, &statbuf) < 0) - tot--; - else if (S_ISDIR(statbuf.st_mode)) { - SETERRNO(EISDIR, SS_NOPRIV); - tot--; - } - else { - if (UNLINK(s)) - { - tot--; - } + } +#endif + } + else { /* don't let root wipe out directories without -U */ + Stat_t statbuf; + if (PerlLIO_lstat(s, &statbuf) < 0) + tot--; + else if (S_ISDIR(statbuf.st_mode)) { + SETERRNO(EISDIR, SS_NOPRIV); + tot--; + } + else { + if (UNLINK(s)) + { + tot--; + } #if defined(__amigaos4__) && defined(NEWLIB) - else - { - /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */ - /* It may not remove the file if it's Locked, so check if it's still */ - /* arround */ - if((access(s,F_OK) != -1)) - { - tot--; - } - } -#endif - } - } - } - break; + else + { + /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */ + /* It may not remove the file if it's Locked, so check if it's still */ + /* arround */ + if((access(s,F_OK) != -1)) + { + tot--; + } + } +#endif + } + } + } + break; #if defined(HAS_UTIME) || defined(HAS_FUTIMES) case OP_UTIME: - APPLY_TAINT_PROPER(); - if (sp - mark > 2) { + APPLY_TAINT_PROPER(); + if (sp - mark > 2) { #if defined(HAS_FUTIMES) - struct timeval utbuf[2]; - void *utbufp = utbuf; + struct timeval utbuf[2]; + void *utbufp = utbuf; #elif defined(I_UTIME) || defined(VMS) - struct utimbuf utbuf; - struct utimbuf *utbufp = &utbuf; + struct utimbuf utbuf; + struct utimbuf *utbufp = &utbuf; #else - struct { - Time_t actime; - Time_t modtime; - } utbuf; - void *utbufp = &utbuf; + struct { + Time_t actime; + Time_t modtime; + } utbuf; + void *utbufp = &utbuf; #endif - SV* const accessed = *++mark; - SV* const modified = *++mark; + SV* const accessed = *++mark; + SV* const modified = *++mark; /* Be like C, and if both times are undefined, let the C * library figure out what to do. This usually means @@ -2735,10 +2735,10 @@ nothing in the core. else { Zero(&utbuf, sizeof utbuf, char); #ifdef HAS_FUTIMES - utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */ - utbuf[0].tv_usec = 0; - utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */ - utbuf[1].tv_usec = 0; + utbuf[0].tv_sec = (long)SvIV(accessed); /* time accessed */ + utbuf[0].tv_usec = 0; + utbuf[1].tv_sec = (long)SvIV(modified); /* time modified */ + utbuf[1].tv_usec = 0; #elif defined(BIG_TIME) utbuf.actime = (Time_t)SvNV(accessed); /* time accessed */ utbuf.modtime = (Time_t)SvNV(modified); /* time modified */ @@ -2747,48 +2747,48 @@ nothing in the core. utbuf.modtime = (Time_t)SvIV(modified); /* time modified */ #endif } - APPLY_TAINT_PROPER(); - tot = sp - mark; - while (++mark <= sp) { + APPLY_TAINT_PROPER(); + tot = sp - mark; + while (++mark <= sp) { GV* gv; if ((gv = MAYBE_DEREF_GV(*mark))) { - if (GvIO(gv) && IoIFP(GvIOp(gv))) { + if (GvIO(gv) && IoIFP(GvIOp(gv))) { #ifdef HAS_FUTIMES int fd = PerlIO_fileno(IoIFP(GvIOn(gv))); - APPLY_TAINT_PROPER(); + APPLY_TAINT_PROPER(); if (fd < 0) { SETERRNO(EBADF,RMS_IFI); tot--; - } else if (futimes(fd, (struct timeval *) utbufp)) - tot--; + } else if (futimes(fd, (struct timeval *) utbufp)) + tot--; #else - Perl_die(aTHX_ PL_no_func, "futimes"); -#endif - } - else { - tot--; - } - } - else { - const char * const name = SvPV_nomg_const(*mark, len); - APPLY_TAINT_PROPER(); - if (!IS_SAFE_PATHNAME(name, len, "utime")) { + Perl_die(aTHX_ PL_no_func, "futimes"); +#endif + } + else { + tot--; + } + } + else { + const char * const name = SvPV_nomg_const(*mark, len); + APPLY_TAINT_PROPER(); + if (!IS_SAFE_PATHNAME(name, len, "utime")) { tot--; } else #ifdef HAS_FUTIMES - if (utimes(name, (struct timeval *)utbufp)) + if (utimes(name, (struct timeval *)utbufp)) #else - if (PerlLIO_utime(name, utbufp)) + if (PerlLIO_utime(name, utbufp)) #endif - tot--; - } + tot--; + } - } - } - else - tot = 0; - break; + } + } + else + tot = 0; + break; #endif } return tot; @@ -2837,24 +2837,24 @@ Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp) # else if ((effective ? PerlProc_geteuid() : PerlProc_getuid()) == 0) { /* root is special */ # endif - if (mode == S_IXUSR) { - if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) - return TRUE; - } - else - return TRUE; /* root reads and writes anything */ - return FALSE; + if (mode == S_IXUSR) { + if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode)) + return TRUE; + } + else + return TRUE; /* root reads and writes anything */ + return FALSE; } if (statbufp->st_uid == (effective ? PerlProc_geteuid() : PerlProc_getuid()) ) { - if (statbufp->st_mode & mode) - return TRUE; /* ok as "user" */ + if (statbufp->st_mode & mode) + return TRUE; /* ok as "user" */ } else if (ingroup(statbufp->st_gid,effective)) { - if (statbufp->st_mode & mode >> 3) - return TRUE; /* ok as "group" */ + if (statbufp->st_mode & mode >> 3) + return TRUE; /* ok as "group" */ } else if (statbufp->st_mode & mode >> 6) - return TRUE; /* ok as "other" */ + return TRUE; /* ok as "other" */ return FALSE; #endif /* ! DOSISH */ } @@ -2868,14 +2868,14 @@ S_ingroup(pTHX_ Gid_t testgid, bool effective) PERL_UNUSED_CONTEXT; #endif if (testgid == (effective ? PerlProc_getegid() : PerlProc_getgid())) - return TRUE; + return TRUE; #ifdef HAS_GETGROUPS { - Groups_t *gary = NULL; - I32 anum; + Groups_t *gary = NULL; + I32 anum; bool rc = FALSE; - anum = getgroups(0, gary); + anum = getgroups(0, gary); if (anum > 0) { Newx(gary, anum, Groups_t); anum = getgroups(anum, gary); @@ -2911,20 +2911,20 @@ Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) { #ifdef HAS_MSG case OP_MSGGET: - return msgget(key, flags); + return msgget(key, flags); #endif #ifdef HAS_SEM case OP_SEMGET: - return semget(key, (int) SvIV(nsv), flags); + return semget(key, (int) SvIV(nsv), flags); #endif #ifdef HAS_SHM case OP_SHMGET: - return shmget(key, (size_t) SvUV(nsv), flags); + return shmget(key, (size_t) SvUV(nsv), flags); #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: /* diag_listed_as: msg%s not implemented */ - Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); + Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } return -1; /* should never happen */ @@ -2951,71 +2951,71 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) { #ifdef HAS_MSG case OP_MSGCTL: - if (cmd == IPC_STAT || cmd == IPC_SET) - infosize = sizeof(struct msqid_ds); - break; + if (cmd == IPC_STAT || cmd == IPC_SET) + infosize = sizeof(struct msqid_ds); + break; #endif #ifdef HAS_SHM case OP_SHMCTL: - if (cmd == IPC_STAT || cmd == IPC_SET) - infosize = sizeof(struct shmid_ds); - break; + if (cmd == IPC_STAT || cmd == IPC_SET) + infosize = sizeof(struct shmid_ds); + break; #endif #ifdef HAS_SEM case OP_SEMCTL: #ifdef Semctl - if (cmd == IPC_STAT || cmd == IPC_SET) - infosize = sizeof(struct semid_ds); - else if (cmd == GETALL || cmd == SETALL) - { - struct semid_ds semds; - union semun semun; + if (cmd == IPC_STAT || cmd == IPC_SET) + infosize = sizeof(struct semid_ds); + else if (cmd == GETALL || cmd == SETALL) + { + struct semid_ds semds; + union semun semun; #ifdef EXTRA_F_IN_SEMUN_BUF semun.buff = &semds; #else semun.buf = &semds; #endif - getinfo = (cmd == GETALL); - if (Semctl(id, 0, IPC_STAT, semun) == -1) - return -1; - infosize = semds.sem_nsems * sizeof(short); - /* "short" is technically wrong but much more portable - than guessing about u_?short(_t)? */ - } + getinfo = (cmd == GETALL); + if (Semctl(id, 0, IPC_STAT, semun) == -1) + return -1; + infosize = semds.sem_nsems * sizeof(short); + /* "short" is technically wrong but much more portable + than guessing about u_?short(_t)? */ + } #else /* diag_listed_as: sem%s not implemented */ - Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); + Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif - break; + break; #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: /* diag_listed_as: shm%s not implemented */ - Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); + Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } if (infosize) { - if (getinfo) - { + if (getinfo) + { /* we're not using the value here, so don't SvPVanything */ SvUPGRADE(astr, SVt_PV); SvGETMAGIC(astr); if (SvTHINKFIRST(astr)) sv_force_normal_flags(astr, 0); - a = SvGROW(astr, infosize+1); - } - else - { - STRLEN len; - a = SvPVbyte(astr, len); - if (len != infosize) - Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld", - PL_op_desc[optype], - (unsigned long)len, - (long)infosize); - } + a = SvGROW(astr, infosize+1); + } + else + { + STRLEN len; + a = SvPVbyte(astr, len); + if (len != infosize) + Perl_croak(aTHX_ "Bad arg length for %s, is %lu, should be %ld", + PL_op_desc[optype], + (unsigned long)len, + (long)infosize); + } } else { @@ -3037,8 +3037,8 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) { #ifdef HAS_MSG case OP_MSGCTL: - ret = msgctl(id, cmd, (struct msqid_ds *)a); - break; + ret = msgctl(id, cmd, (struct msqid_ds *)a); + break; #endif #ifdef HAS_SEM case OP_SEMCTL: { @@ -3055,25 +3055,25 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) unsemds.buf = (struct semid_ds *)a; #endif } - ret = Semctl(id, n, cmd, unsemds); + ret = Semctl(id, n, cmd, unsemds); #else - /* diag_listed_as: sem%s not implemented */ - Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); + /* diag_listed_as: sem%s not implemented */ + Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } - break; + break; #endif #ifdef HAS_SHM case OP_SHMCTL: - ret = shmctl(id, cmd, (struct shmid_ds *)a); - break; + ret = shmctl(id, cmd, (struct shmid_ds *)a); + break; #endif } if (getinfo && ret >= 0) { - SvCUR_set(astr, infosize); - *SvEND(astr) = '\0'; + SvCUR_set(astr, infosize); + *SvEND(astr) = '\0'; SvPOK_only(astr); - SvSETMAGIC(astr); + SvSETMAGIC(astr); } return ret; } @@ -3093,7 +3093,7 @@ Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) PERL_UNUSED_ARG(sp); if (msize < 0) - Perl_croak(aTHX_ "Arg too short for msgsnd"); + Perl_croak(aTHX_ "Arg too short for msgsnd"); SETERRNO(0,0); if (id >= 0 && flags >= 0) { return msgsnd(id, (struct msgbuf *)mbuf, msize, flags); @@ -3140,11 +3140,11 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) ret = -1; } if (ret >= 0) { - SvCUR_set(mstr, sizeof(long)+ret); + SvCUR_set(mstr, sizeof(long)+ret); SvPOK_only(mstr); - *SvEND(mstr) = '\0'; - /* who knows who has been playing with this message? */ - SvTAINTED_on(mstr); + *SvEND(mstr) = '\0'; + /* who knows who has been playing with this message? */ + SvTAINTED_on(mstr); } return ret; #else @@ -3169,9 +3169,9 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp) PERL_UNUSED_ARG(sp); if (opsize < 3 * SHORTSIZE - || (opsize % (3 * SHORTSIZE))) { - SETERRNO(EINVAL,LIB_INVARG); - return -1; + || (opsize % (3 * SHORTSIZE))) { + SETERRNO(EINVAL,LIB_INVARG); + return -1; } SETERRNO(0,0); /* We can't assume that sizeof(struct sembuf) == 3 * sizeof(short). */ @@ -3217,11 +3217,11 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) SETERRNO(0,0); if (shmctl(id, IPC_STAT, &shmds) == -1) - return -1; + return -1; if (mpos < 0 || msize < 0 - || (size_t)mpos + msize > (size_t)shmds.shm_segsz) { - SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */ - return -1; + || (size_t)mpos + msize > (size_t)shmds.shm_segsz) { + SETERRNO(EFAULT,SS_ACCVIO); /* can't do as caller requested */ + return -1; } if (id >= 0) { shm = (char *)shmat(id, NULL, (optype == OP_SHMREAD) ? SHM_RDONLY : 0); @@ -3230,32 +3230,32 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) return -1; } if (shm == (char *)-1) /* I hate System V IPC, I really do */ - return -1; + return -1; if (optype == OP_SHMREAD) { - char *mbuf; - /* suppress warning when reading into undef var (tchrist 3/Mar/00) */ - SvGETMAGIC(mstr); - SvUPGRADE(mstr, SVt_PV); - if (! SvOK(mstr)) + char *mbuf; + /* suppress warning when reading into undef var (tchrist 3/Mar/00) */ + SvGETMAGIC(mstr); + SvUPGRADE(mstr, SVt_PV); + if (! SvOK(mstr)) SvPVCLEAR(mstr); - SvPOK_only(mstr); - mbuf = SvGROW(mstr, (STRLEN)msize+1); + SvPOK_only(mstr); + mbuf = SvGROW(mstr, (STRLEN)msize+1); - Copy(shm + mpos, mbuf, msize, char); - SvCUR_set(mstr, msize); - *SvEND(mstr) = '\0'; - SvSETMAGIC(mstr); - /* who knows who has been playing with this shared memory? */ - SvTAINTED_on(mstr); + Copy(shm + mpos, mbuf, msize, char); + SvCUR_set(mstr, msize); + *SvEND(mstr) = '\0'; + SvSETMAGIC(mstr); + /* who knows who has been playing with this shared memory? */ + SvTAINTED_on(mstr); } else { - STRLEN len; + STRLEN len; - const char *mbuf = SvPVbyte(mstr, len); - const I32 n = ((I32)len > msize) ? msize : (I32)len; - Copy(mbuf, shm + mpos, n, char); - if (n < msize) - memzero(shm + mpos + n, msize - n); + const char *mbuf = SvPVbyte(mstr, len); + const I32 n = ((I32)len > msize) ? msize : (I32)len; + Copy(mbuf, shm + mpos, n, char); + if (n < msize) + memzero(shm + mpos + n, msize - n); } return shmdt(shm); #else @@ -53,57 +53,57 @@ S_do_trans_simple(pTHX_ SV * const sv, const OPtrans_map * const tbl) /* First, take care of non-UTF-8 input strings, because they're easy */ if (!SvUTF8(sv)) { - while (s < send) { - const short ch = tbl->map[*s]; - if (ch >= 0) { - matches++; - *s = (U8)ch; - } - s++; - } - SvSETMAGIC(sv); + while (s < send) { + const short ch = tbl->map[*s]; + if (ch >= 0) { + matches++; + *s = (U8)ch; + } + s++; + } + SvSETMAGIC(sv); } else { - const bool grows = cBOOL(PL_op->op_private & OPpTRANS_GROWS); - U8 *d; - U8 *dstart; + const bool grows = cBOOL(PL_op->op_private & OPpTRANS_GROWS); + U8 *d; + U8 *dstart; /* Allow for worst-case expansion: Each input byte can become 2. For a * given input character, this happens when it occupies a single byte * under UTF-8, but is to be translated to something that occupies two: * $_="a".chr(400); tr/a/\xFE/, FE needs encoding. */ - if (grows) - Newx(d, len*2+1, U8); - else - d = s; - dstart = d; - while (s < send) { - STRLEN ulen; - short ch; - - /* Need to check this, otherwise 128..255 won't match */ - const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT); - if (c < 0x100 && (ch = tbl->map[c]) >= 0) { - matches++; - d = uvchr_to_utf8(d, (UV)ch); - s += ulen; - } - else { /* No match -> copy */ - Move(s, d, ulen, U8); - d += ulen; - s += ulen; - } - } - if (grows) { - sv_setpvn(sv, (char*)dstart, d - dstart); - Safefree(dstart); - } - else { - *d = '\0'; - SvCUR_set(sv, d - dstart); - } - SvUTF8_on(sv); - SvSETMAGIC(sv); + if (grows) + Newx(d, len*2+1, U8); + else + d = s; + dstart = d; + while (s < send) { + STRLEN ulen; + short ch; + + /* Need to check this, otherwise 128..255 won't match */ + const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT); + if (c < 0x100 && (ch = tbl->map[c]) >= 0) { + matches++; + d = uvchr_to_utf8(d, (UV)ch); + s += ulen; + } + else { /* No match -> copy */ + Move(s, d, ulen, U8); + d += ulen; + s += ulen; + } + } + if (grows) { + sv_setpvn(sv, (char*)dstart, d - dstart); + Safefree(dstart); + } + else { + *d = '\0'; + SvCUR_set(sv, d - dstart); + } + SvUTF8_on(sv); + SvSETMAGIC(sv); } DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %zu\n", __FILE__, __LINE__, matches)); @@ -140,23 +140,23 @@ S_do_trans_count(pTHX_ SV * const sv, const OPtrans_map * const tbl) DEBUG_y(sv_dump(sv)); if (!SvUTF8(sv)) { - while (s < send) { + while (s < send) { if (tbl->map[*s++] >= 0) matches++; - } + } } else { - const bool complement = cBOOL(PL_op->op_private & OPpTRANS_COMPLEMENT); - while (s < send) { - STRLEN ulen; - const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT); - if (c < 0x100) { - if (tbl->map[c] >= 0) - matches++; - } else if (complement) - matches++; - s += ulen; - } + const bool complement = cBOOL(PL_op->op_private & OPpTRANS_COMPLEMENT); + while (s < send) { + STRLEN ulen; + const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT); + if (c < 0x100) { + if (tbl->map[c] >= 0) + matches++; + } else if (complement) + matches++; + s += ulen; + } } DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: count returning %zu\n", @@ -190,26 +190,26 @@ S_do_trans_complex(pTHX_ SV * const sv, const OPtrans_map * const tbl) DEBUG_y(sv_dump(sv)); if (!SvUTF8(sv)) { - U8 *d = s; - U8 * const dstart = d; + U8 *d = s; + U8 * const dstart = d; - if (PL_op->op_private & OPpTRANS_SQUASH) { + if (PL_op->op_private & OPpTRANS_SQUASH) { /* What the mapping of the previous character was to. If the new * character has the same mapping, it is squashed from the output * (but still is included in the count) */ short previous_map = (short) TR_OOB; - while (s < send) { - const short this_map = tbl->map[*s]; - if (this_map >= 0) { + while (s < send) { + const short this_map = tbl->map[*s]; + if (this_map >= 0) { matches++; if (this_map != previous_map) { *d++ = (U8)this_map; previous_map = this_map; } - } - else { + } + else { if (this_map == (short) TR_UNMAPPED) { *d++ = *s; previous_map = (short) TR_OOB; @@ -220,47 +220,47 @@ S_do_trans_complex(pTHX_ SV * const sv, const OPtrans_map * const tbl) } } - s++; - } - } - else { /* Not to squash */ - while (s < send) { - const short this_map = tbl->map[*s]; - if (this_map >= 0) { - matches++; - *d++ = (U8)this_map; - } - else if (this_map == (short) TR_UNMAPPED) - *d++ = *s; - else if (this_map == (short) TR_DELETE) - matches++; - s++; - } - } - *d = '\0'; - SvCUR_set(sv, d - dstart); + s++; + } + } + else { /* Not to squash */ + while (s < send) { + const short this_map = tbl->map[*s]; + if (this_map >= 0) { + matches++; + *d++ = (U8)this_map; + } + else if (this_map == (short) TR_UNMAPPED) + *d++ = *s; + else if (this_map == (short) TR_DELETE) + matches++; + s++; + } + } + *d = '\0'; + SvCUR_set(sv, d - dstart); } else { /* is utf8 */ - const bool squash = cBOOL(PL_op->op_private & OPpTRANS_SQUASH); - const bool grows = cBOOL(PL_op->op_private & OPpTRANS_GROWS); - U8 *d; - U8 *dstart; - Size_t size = tbl->size; + const bool squash = cBOOL(PL_op->op_private & OPpTRANS_SQUASH); + const bool grows = cBOOL(PL_op->op_private & OPpTRANS_GROWS); + U8 *d; + U8 *dstart; + Size_t size = tbl->size; /* What the mapping of the previous character was to. If the new * character has the same mapping, it is squashed from the output (but * still is included in the count) */ UV pch = TR_OOB; - if (grows) + if (grows) /* Allow for worst-case expansion: Each input byte can become 2. * For a given input character, this happens when it occupies a * single byte under UTF-8, but is to be translated to something * that occupies two: */ - Newx(d, len*2+1, U8); - else - d = s; - dstart = d; + Newx(d, len*2+1, U8); + else + d = s; + dstart = d; while (s < send) { STRLEN len; @@ -302,15 +302,15 @@ S_do_trans_complex(pTHX_ SV * const sv, const OPtrans_map * const tbl) s += len; } - if (grows) { - sv_setpvn(sv, (char*)dstart, d - dstart); - Safefree(dstart); - } - else { - *d = '\0'; - SvCUR_set(sv, d - dstart); - } - SvUTF8_on(sv); + if (grows) { + sv_setpvn(sv, (char*)dstart, d - dstart); + Safefree(dstart); + } + else { + *d = '\0'; + SvCUR_set(sv, d - dstart); + } + SvUTF8_on(sv); } SvSETMAGIC(sv); DEBUG_y(PerlIO_printf(Perl_debug_log, "%s: %d: returning %zu\n", @@ -459,7 +459,7 @@ S_do_trans_invmap(pTHX_ SV * const sv, AV * const invmap) * transliterations are longer than the input. If none can, we just edit * in place. */ if (inplace) { - d0 = d = s; + d0 = d = s; } else { /* Here, we can't edit in place. We have no idea how much, if any, @@ -467,8 +467,8 @@ S_do_trans_invmap(pTHX_ SV * const sv, AV * const invmap) * calculated the maximum expansion possible. Use that to allocate * based on the worst case scenario. (First +1 is to round up; 2nd is * for \0) */ - Newx(d, (STRLEN) (len * max_expansion + 1 + 1), U8); - d0 = d; + Newx(d, (STRLEN) (len * max_expansion + 1 + 1), U8); + d0 = d; } restart: @@ -514,7 +514,7 @@ S_do_trans_invmap(pTHX_ SV * const sv, AV * const invmap) previous_map = to; s += s_len; continue; - } + } /* Everything else is counted as a match */ matches++; @@ -558,12 +558,12 @@ S_do_trans_invmap(pTHX_ SV * const sv, AV * const invmap) s_len = 0; s += s_len; if (! inplace) { - sv_setpvn(sv, (char*)d0, d - d0); + sv_setpvn(sv, (char*)d0, d - d0); Safefree(d0); } else { - *d = '\0'; - SvCUR_set(sv, d - d0); + *d = '\0'; + SvCUR_set(sv, d - d0); } if (! SvUTF8(sv) && out_is_utf8) { @@ -599,11 +599,11 @@ Perl_do_trans(pTHX_ SV *sv) } (void)SvPV_const(sv, len); if (!len) - return 0; + return 0; if (! identical) { - if (!SvPOKp(sv) || SvTHINKFIRST(sv)) - (void)SvPV_force_nomg(sv, len); - (void)SvPOK_only_UTF8(sv); + if (!SvPOKp(sv) || SvTHINKFIRST(sv)) + (void)SvPV_force_nomg(sv, len); + (void)SvPOK_only_UTF8(sv); } if (use_utf8_fcns) { @@ -650,19 +650,19 @@ Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp) len = (items > 0 ? (delimlen * (items - 1) ) : 0); SvUPGRADE(sv, SVt_PV); if (SvLEN(sv) < len + items) { /* current length is way too short */ - while (items-- > 0) { - if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) { - STRLEN tmplen; - SvPV_const(*mark, tmplen); - len += tmplen; - } - mark++; - } - SvGROW(sv, len + 1); /* so try to pre-extend */ - - mark = oldmark; - items = sp - mark; - ++mark; + while (items-- > 0) { + if (*mark && !SvGAMAGIC(*mark) && SvOK(*mark)) { + STRLEN tmplen; + SvPV_const(*mark, tmplen); + len += tmplen; + } + mark++; + } + SvGROW(sv, len + 1); /* so try to pre-extend */ + + mark = oldmark; + items = sp - mark; + ++mark; } SvPVCLEAR(sv); @@ -670,33 +670,33 @@ Perl_do_join(pTHX_ SV *sv, SV *delim, SV **mark, SV **sp) SvUTF8_off(sv); if (TAINTING_get && SvMAGICAL(sv)) - SvTAINTED_off(sv); + SvTAINTED_off(sv); if (items-- > 0) { - if (*mark) - sv_catsv(sv, *mark); - mark++; + if (*mark) + sv_catsv(sv, *mark); + mark++; } if (delimlen) { - const U32 delimflag = DO_UTF8(delim) ? SV_CATUTF8 : SV_CATBYTES; - for (; items > 0; items--,mark++) { - STRLEN len; - const char *s; - sv_catpvn_flags(sv,delims,delimlen,delimflag); - s = SvPV_const(*mark,len); - sv_catpvn_flags(sv,s,len, - DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES); - } + const U32 delimflag = DO_UTF8(delim) ? SV_CATUTF8 : SV_CATBYTES; + for (; items > 0; items--,mark++) { + STRLEN len; + const char *s; + sv_catpvn_flags(sv,delims,delimlen,delimflag); + s = SvPV_const(*mark,len); + sv_catpvn_flags(sv,s,len, + DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES); + } } else { - for (; items > 0; items--,mark++) - { - STRLEN len; - const char *s = SvPV_const(*mark,len); - sv_catpvn_flags(sv,s,len, - DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES); - } + for (; items > 0; items--,mark++) + { + STRLEN len; + const char *s = SvPV_const(*mark,len); + sv_catpvn_flags(sv,s,len, + DO_UTF8(*mark) ? SV_CATUTF8 : SV_CATBYTES); + } } SvSETMAGIC(sv); } @@ -712,20 +712,20 @@ Perl_do_sprintf(pTHX_ SV *sv, SSize_t len, SV **sarg) assert(len >= 1); if (SvTAINTED(*sarg)) - TAINT_PROPER( - (PL_op && PL_op->op_type < OP_max) - ? (PL_op->op_type == OP_PRTF) - ? "printf" - : PL_op_name[PL_op->op_type] - : "(unknown)" - ); + TAINT_PROPER( + (PL_op && PL_op->op_type < OP_max) + ? (PL_op->op_type == OP_PRTF) + ? "printf" + : PL_op_name[PL_op->op_type] + : "(unknown)" + ); SvUTF8_off(sv); if (DO_UTF8(*sarg)) SvUTF8_on(sv); sv_vsetpvfn(sv, pat, patlen, NULL, sarg + 1, (Size_t)(len - 1), &do_taint); SvSETMAGIC(sv); if (do_taint) - SvTAINTED_on(sv); + SvTAINTED_on(sv); } UV @@ -745,10 +745,10 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size) PERL_ARGS_ASSERT_DO_VECGET; if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ - Perl_croak(aTHX_ "Illegal number of bits in vec"); + Perl_croak(aTHX_ "Illegal number of bits in vec"); if (SvUTF8(sv)) { - if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) { + if (Perl_sv_utf8_downgrade_flags(aTHX_ sv, TRUE, 0)) { /* PVX may have changed */ s = (unsigned char *) SvPV_flags(sv, srclen, svpv_flags); } @@ -759,17 +759,17 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size) } if (size < 8) { - bitoffs = ((offset%8)*size)%8; - uoffset = offset/(8/size); + bitoffs = ((offset%8)*size)%8; + uoffset = offset/(8/size); } else if (size > 8) { - int n = size/8; + int n = size/8; if (offset > Size_t_MAX / n - 1) /* would overflow */ return 0; - uoffset = offset*n; + uoffset = offset*n; } else - uoffset = offset; + uoffset = offset; if (uoffset >= srclen) return 0; @@ -780,108 +780,108 @@ Perl_do_vecget(pTHX_ SV *sv, STRLEN offset, int size) /* Does the byte range overlap the end of the string? If so, * handle specially. */ if (avail < len) { - if (size <= 8) - retnum = 0; - else { - if (size == 16) { + if (size <= 8) + retnum = 0; + else { + if (size == 16) { assert(avail == 1); retnum = (UV) s[uoffset] << 8; - } - else if (size == 32) { + } + else if (size == 32) { assert(avail >= 1 && avail <= 3); - if (avail == 1) - retnum = - ((UV) s[uoffset ] << 24); - else if (avail == 2) - retnum = - ((UV) s[uoffset ] << 24) + - ((UV) s[uoffset + 1] << 16); - else - retnum = - ((UV) s[uoffset ] << 24) + - ((UV) s[uoffset + 1] << 16) + - ( s[uoffset + 2] << 8); - } + if (avail == 1) + retnum = + ((UV) s[uoffset ] << 24); + else if (avail == 2) + retnum = + ((UV) s[uoffset ] << 24) + + ((UV) s[uoffset + 1] << 16); + else + retnum = + ((UV) s[uoffset ] << 24) + + ((UV) s[uoffset + 1] << 16) + + ( s[uoffset + 2] << 8); + } #ifdef UV_IS_QUAD - else if (size == 64) { - Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), - "Bit vector size > 32 non-portable"); + else if (size == 64) { + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Bit vector size > 32 non-portable"); assert(avail >= 1 && avail <= 7); - if (avail == 1) - retnum = - (UV) s[uoffset ] << 56; - else if (avail == 2) - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48); - else if (avail == 3) - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40); - else if (avail == 4) - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40) + - ((UV) s[uoffset + 3] << 32); - else if (avail == 5) - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40) + - ((UV) s[uoffset + 3] << 32) + - ((UV) s[uoffset + 4] << 24); - else if (avail == 6) - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40) + - ((UV) s[uoffset + 3] << 32) + - ((UV) s[uoffset + 4] << 24) + - ((UV) s[uoffset + 5] << 16); - else - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40) + - ((UV) s[uoffset + 3] << 32) + - ((UV) s[uoffset + 4] << 24) + - ((UV) s[uoffset + 5] << 16) + - ((UV) s[uoffset + 6] << 8); - } + if (avail == 1) + retnum = + (UV) s[uoffset ] << 56; + else if (avail == 2) + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48); + else if (avail == 3) + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40); + else if (avail == 4) + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40) + + ((UV) s[uoffset + 3] << 32); + else if (avail == 5) + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40) + + ((UV) s[uoffset + 3] << 32) + + ((UV) s[uoffset + 4] << 24); + else if (avail == 6) + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40) + + ((UV) s[uoffset + 3] << 32) + + ((UV) s[uoffset + 4] << 24) + + ((UV) s[uoffset + 5] << 16); + else + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40) + + ((UV) s[uoffset + 3] << 32) + + ((UV) s[uoffset + 4] << 24) + + ((UV) s[uoffset + 5] << 16) + + ((UV) s[uoffset + 6] << 8); + } #endif - } + } } else if (size < 8) - retnum = (s[uoffset] >> bitoffs) & nBIT_MASK(size); + retnum = (s[uoffset] >> bitoffs) & nBIT_MASK(size); else { - if (size == 8) - retnum = s[uoffset]; - else if (size == 16) - retnum = - ((UV) s[uoffset] << 8) + - s[uoffset + 1]; - else if (size == 32) - retnum = - ((UV) s[uoffset ] << 24) + - ((UV) s[uoffset + 1] << 16) + - ( s[uoffset + 2] << 8) + - s[uoffset + 3]; + if (size == 8) + retnum = s[uoffset]; + else if (size == 16) + retnum = + ((UV) s[uoffset] << 8) + + s[uoffset + 1]; + else if (size == 32) + retnum = + ((UV) s[uoffset ] << 24) + + ((UV) s[uoffset + 1] << 16) + + ( s[uoffset + 2] << 8) + + s[uoffset + 3]; #ifdef UV_IS_QUAD - else if (size == 64) { - Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), - "Bit vector size > 32 non-portable"); - retnum = - ((UV) s[uoffset ] << 56) + - ((UV) s[uoffset + 1] << 48) + - ((UV) s[uoffset + 2] << 40) + - ((UV) s[uoffset + 3] << 32) + - ((UV) s[uoffset + 4] << 24) + - ((UV) s[uoffset + 5] << 16) + - ( s[uoffset + 6] << 8) + - s[uoffset + 7]; - } + else if (size == 64) { + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Bit vector size > 32 non-portable"); + retnum = + ((UV) s[uoffset ] << 56) + + ((UV) s[uoffset + 1] << 48) + + ((UV) s[uoffset + 2] << 40) + + ((UV) s[uoffset + 3] << 32) + + ((UV) s[uoffset + 4] << 24) + + ((UV) s[uoffset + 5] << 16) + + ( s[uoffset + 6] << 8) + + s[uoffset + 7]; + } #endif } @@ -917,15 +917,15 @@ Perl_do_vecset(pTHX_ SV *sv) } if (!targ) - return; + return; s = (unsigned char*)SvPV_force_flags(targ, targlen, SV_GMAGIC | SV_UNDEF_RETURNS_NULL); if (SvUTF8(targ)) { - /* This is handled by the SvPOK_only below... - if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0)) - SvUTF8_off(targ); - */ - (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0); + /* This is handled by the SvPOK_only below... + if (!Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0)) + SvUTF8_off(targ); + */ + (void) Perl_sv_utf8_downgrade_flags(aTHX_ targ, TRUE, 0); } (void)SvPOK_only(targ); @@ -934,60 +934,60 @@ Perl_do_vecset(pTHX_ SV *sv) size = LvTARGLEN(sv); if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */ - Perl_croak(aTHX_ "Illegal number of bits in vec"); + Perl_croak(aTHX_ "Illegal number of bits in vec"); if (size < 8) { - bitoffs = ((offset%8)*size)%8; - offset /= 8/size; + bitoffs = ((offset%8)*size)%8; + offset /= 8/size; } else if (size > 8) { - int n = size/8; + int n = size/8; if (offset > Size_t_MAX / n - 1) /* would overflow */ Perl_croak_nocontext("Out of memory!"); - offset *= n; + offset *= n; } len = (bitoffs + size + 7)/8; /* required number of bytes */ if (targlen < offset || targlen - offset < len) { STRLEN newlen = offset > Size_t_MAX - len - 1 ? /* avoid overflow */ Size_t_MAX : offset + len + 1; - s = (unsigned char*)SvGROW(targ, newlen); - (void)memzero((char *)(s + targlen), newlen - targlen); - SvCUR_set(targ, newlen - 1); + s = (unsigned char*)SvGROW(targ, newlen); + (void)memzero((char *)(s + targlen), newlen - targlen); + SvCUR_set(targ, newlen - 1); } if (size < 8) { - mask = nBIT_MASK(size); - lval &= mask; - s[offset] &= ~(mask << bitoffs); - s[offset] |= lval << bitoffs; + mask = nBIT_MASK(size); + lval &= mask; + s[offset] &= ~(mask << bitoffs); + s[offset] |= lval << bitoffs; } else { - if (size == 8) - s[offset ] = (U8)( lval & 0xff); - else if (size == 16) { - s[offset ] = (U8)((lval >> 8) & 0xff); - s[offset+1] = (U8)( lval & 0xff); - } - else if (size == 32) { - s[offset ] = (U8)((lval >> 24) & 0xff); - s[offset+1] = (U8)((lval >> 16) & 0xff); - s[offset+2] = (U8)((lval >> 8) & 0xff); - s[offset+3] = (U8)( lval & 0xff); - } + if (size == 8) + s[offset ] = (U8)( lval & 0xff); + else if (size == 16) { + s[offset ] = (U8)((lval >> 8) & 0xff); + s[offset+1] = (U8)( lval & 0xff); + } + else if (size == 32) { + s[offset ] = (U8)((lval >> 24) & 0xff); + s[offset+1] = (U8)((lval >> 16) & 0xff); + s[offset+2] = (U8)((lval >> 8) & 0xff); + s[offset+3] = (U8)( lval & 0xff); + } #ifdef UV_IS_QUAD - else if (size == 64) { - Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), - "Bit vector size > 32 non-portable"); - s[offset ] = (U8)((lval >> 56) & 0xff); - s[offset+1] = (U8)((lval >> 48) & 0xff); - s[offset+2] = (U8)((lval >> 40) & 0xff); - s[offset+3] = (U8)((lval >> 32) & 0xff); - s[offset+4] = (U8)((lval >> 24) & 0xff); - s[offset+5] = (U8)((lval >> 16) & 0xff); - s[offset+6] = (U8)((lval >> 8) & 0xff); - s[offset+7] = (U8)( lval & 0xff); - } + else if (size == 64) { + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Bit vector size > 32 non-portable"); + s[offset ] = (U8)((lval >> 56) & 0xff); + s[offset+1] = (U8)((lval >> 48) & 0xff); + s[offset+2] = (U8)((lval >> 40) & 0xff); + s[offset+3] = (U8)((lval >> 32) & 0xff); + s[offset+4] = (U8)((lval >> 24) & 0xff); + s[offset+5] = (U8)((lval >> 16) & 0xff); + s[offset+6] = (U8)((lval >> 8) & 0xff); + s[offset+7] = (U8)( lval & 0xff); + } #endif } SvSETMAGIC(targ); @@ -1024,11 +1024,11 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) if (sv != left || (optype != OP_BIT_AND && !SvOK(sv))) SvPVCLEAR(sv); /* avoid undef warning on |= and ^= */ if (sv == left) { - lc = SvPV_force_nomg(left, leftlen); + lc = SvPV_force_nomg(left, leftlen); } else { - lc = SvPV_nomg_const(left, leftlen); - SvPV_force_nomg_nolen(sv); + lc = SvPV_nomg_const(left, leftlen); + SvPV_force_nomg_nolen(sv); } rc = SvPV_nomg_const(right, rightlen); @@ -1089,64 +1089,64 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) (void)SvPOK_only(sv); if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { - dc = SvPV_force_nomg_nolen(sv); - if (SvLEN(sv) < len + 1) { - dc = SvGROW(sv, len + 1); - (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); - } + dc = SvPV_force_nomg_nolen(sv); + if (SvLEN(sv) < len + 1) { + dc = SvGROW(sv, len + 1); + (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); + } } else { - needlen = optype == OP_BIT_AND - ? len : (leftlen > rightlen ? leftlen : rightlen); - Newxz(dc, needlen + 1, char); - sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL); - dc = SvPVX(sv); /* sv_usepvn() calls Renew() */ + needlen = optype == OP_BIT_AND + ? len : (leftlen > rightlen ? leftlen : rightlen); + Newxz(dc, needlen + 1, char); + sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL); + dc = SvPVX(sv); /* sv_usepvn() calls Renew() */ } SvCUR_set(sv, len); if (len >= sizeof(long)*4 && - !(PTR2nat(dc) % sizeof(long)) && - !(PTR2nat(lc) % sizeof(long)) && - !(PTR2nat(rc) % sizeof(long))) /* It's almost always aligned... */ + !(PTR2nat(dc) % sizeof(long)) && + !(PTR2nat(lc) % sizeof(long)) && + !(PTR2nat(rc) % sizeof(long))) /* It's almost always aligned... */ { - const STRLEN remainder = len % (sizeof(long)*4); - len /= (sizeof(long)*4); - - dl = (long*)dc; - ll = (long*)lc; - rl = (long*)rc; - - switch (optype) { - case OP_BIT_AND: - while (len--) { - *dl++ = *ll++ & *rl++; - *dl++ = *ll++ & *rl++; - *dl++ = *ll++ & *rl++; - *dl++ = *ll++ & *rl++; - } - break; - case OP_BIT_XOR: - while (len--) { - *dl++ = *ll++ ^ *rl++; - *dl++ = *ll++ ^ *rl++; - *dl++ = *ll++ ^ *rl++; - *dl++ = *ll++ ^ *rl++; - } - break; - case OP_BIT_OR: - while (len--) { - *dl++ = *ll++ | *rl++; - *dl++ = *ll++ | *rl++; - *dl++ = *ll++ | *rl++; - *dl++ = *ll++ | *rl++; - } - } - - dc = (char*)dl; - lc = (char*)ll; - rc = (char*)rl; - - len = remainder; + const STRLEN remainder = len % (sizeof(long)*4); + len /= (sizeof(long)*4); + + dl = (long*)dc; + ll = (long*)lc; + rl = (long*)rc; + + switch (optype) { + case OP_BIT_AND: + while (len--) { + *dl++ = *ll++ & *rl++; + *dl++ = *ll++ & *rl++; + *dl++ = *ll++ & *rl++; + *dl++ = *ll++ & *rl++; + } + break; + case OP_BIT_XOR: + while (len--) { + *dl++ = *ll++ ^ *rl++; + *dl++ = *ll++ ^ *rl++; + *dl++ = *ll++ ^ *rl++; + *dl++ = *ll++ ^ *rl++; + } + break; + case OP_BIT_OR: + while (len--) { + *dl++ = *ll++ | *rl++; + *dl++ = *ll++ | *rl++; + *dl++ = *ll++ | *rl++; + *dl++ = *ll++ | *rl++; + } + } + + dc = (char*)dl; + lc = (char*)ll; + rc = (char*)rl; + + len = remainder; } switch (optype) { @@ -1242,42 +1242,42 @@ Perl_do_kv(pTHX) (void)hv_iterinit(keys); /* always reset iterator regardless */ if (gimme == G_VOID) - RETURN; + RETURN; if (gimme == G_SCALAR) { - if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ - SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ - sv_magic(ret, NULL, PERL_MAGIC_nkeys, NULL, 0); - LvTYPE(ret) = 'k'; - LvTARG(ret) = SvREFCNT_inc_simple(keys); - PUSHs(ret); - } - else { - IV i; - dTARGET; + if (PL_op->op_flags & OPf_MOD || LVRET) { /* lvalue */ + SV * const ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */ + sv_magic(ret, NULL, PERL_MAGIC_nkeys, NULL, 0); + LvTYPE(ret) = 'k'; + LvTARG(ret) = SvREFCNT_inc_simple(keys); + PUSHs(ret); + } + else { + IV i; + dTARGET; /* note that in 'scalar(keys %h)' the OP_KEYS is usually * optimised away and the action is performed directly by the * padhv or rv2hv op. We now only get here via OP_AVHVSWITCH * and \&CORE::keys */ - if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) { - i = HvUSEDKEYS(keys); - } - else { - i = 0; - while (hv_iternext(keys)) i++; - } - PUSHi( i ); - } - RETURN; + if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) { + i = HvUSEDKEYS(keys); + } + else { + i = 0; + while (hv_iternext(keys)) i++; + } + PUSHi( i ); + } + RETURN; } if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { - const I32 flags = is_lvalue_sub(); - if (flags && !(flags & OPpENTERSUB_INARGS)) - /* diag_listed_as: Can't modify %s in %s */ - Perl_croak(aTHX_ "Can't modify keys in list assignment"); + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) + /* diag_listed_as: Can't modify %s in %s */ + Perl_croak(aTHX_ "Can't modify keys in list assignment"); } PUTBACK; @@ -17,7 +17,7 @@ # define BIT_BUCKET "nul" # define OP_BINARY O_BINARY # define PERL_SYS_INIT_BODY(c,v) \ - MALLOC_CHECK_TAINT2(*c,*v) Perl_DJGPP_init(c,v); PERLIO_INIT + MALLOC_CHECK_TAINT2(*c,*v) Perl_DJGPP_init(c,v); PERLIO_INIT # define init_os_extras Perl_init_os_extras # define HAS_UTIME # define HAS_KILL @@ -30,8 +30,8 @@ # define PERL_FS_VER_FMT "%d_%d_%d" # endif # define PERL_FS_VERSION STRINGIFY(PERL_REVISION) "_" \ - STRINGIFY(PERL_VERSION) "_" \ - STRINGIFY(PERL_SUBVERSION) + STRINGIFY(PERL_VERSION) "_" \ + STRINGIFY(PERL_SUBVERSION) #elif defined(WIN32) # define PERL_SYS_INIT_BODY(c,v) \ MALLOC_CHECK_TAINT2(*c,*v) Perl_win32_init(c,v); PERLIO_INIT @@ -117,7 +117,7 @@ Perl_form_alien_digit_msg(pTHX_ /* It also isn't a UTF-8 invariant character, so no display shortcuts * are available. Use \\x{...} */ - Perl_sv_setpvf(aTHX_ display_char, "\\x{%02x}", *first_bad); + Perl_sv_setpvf(aTHX_ display_char, "\\x{%02x}", *first_bad); } /* Ready to start building the message */ @@ -286,8 +286,8 @@ Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv, (*s)++; if (send <= *s || **s != '{') { - *message = "Missing braces on \\o{}"; - return FALSE; + *message = "Missing braces on \\o{}"; + return FALSE; } e = (char *) memchr(*s, '}', send - *s); @@ -297,7 +297,7 @@ Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv, (*s)++; } *message = "Missing right brace on \\o{}"; - return FALSE; + return FALSE; } (*s)++; /* Point to expected first digit (could be first byte of utf8 @@ -305,8 +305,8 @@ Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv, numbers_len = e - *s; if (numbers_len == 0) { (*s)++; /* Move past the '}' */ - *message = "Empty \\o{}"; - return FALSE; + *message = "Empty \\o{}"; + return FALSE; } *uv = grok_oct(*s, &numbers_len, &flags, NULL); @@ -423,8 +423,8 @@ Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv, if (**s != '{') { numbers_len = (strict) ? 3 : 2; - *uv = grok_hex(*s, &numbers_len, &flags, NULL); - *s += numbers_len; + *uv = grok_hex(*s, &numbers_len, &flags, NULL); + *s += numbers_len; if (numbers_len != 2 && (strict || (flags & PERL_SCAN_NOTIFY_ILLDIGIT))) { if (numbers_len == 3) { /* numbers_len 3 only happens with strict */ @@ -449,7 +449,7 @@ Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv, } } } - return TRUE; + return TRUE; } e = (char *) memchr(*s, '}', send - *s); @@ -458,8 +458,8 @@ Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv, while (*s < send && isXDIGIT(**s)) { /* Position beyond legal digits */ (*s)++; } - *message = "Missing right brace on \\x{}"; - return FALSE; + *message = "Missing right brace on \\x{}"; + return FALSE; } (*s)++; /* Point to expected first digit (could be first byte of utf8 @@ -75,11 +75,11 @@ struct flag_to_name { static void S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start, - const struct flag_to_name *const end) + const struct flag_to_name *const end) { do { - if (flags & start->flag) - sv_catpv(sv, start->name); + if (flags & start->flag) + sv_catpv(sv, start->name); } while (++start < end); } @@ -172,7 +172,7 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, PERL_ARGS_ASSERT_PV_ESCAPE; if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) { - /* This won't alter the UTF-8 flag */ + /* This won't alter the UTF-8 flag */ SvPVCLEAR(dsv); } @@ -184,9 +184,9 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, const U8 c = (U8)u & 0xFF; if ( ( u > 255 ) - || (flags & PERL_PV_ESCAPE_ALL) - || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM)))) - { + || (flags & PERL_PV_ESCAPE_ALL) + || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM)))) + { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, "%" UVxf, u); @@ -200,28 +200,28 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, chsize = 1; } else { if ( (c == dq) || (c == esc) || !isPRINT(c) ) { - chsize = 2; + chsize = 2; switch (c) { - case '\\' : /* FALLTHROUGH */ - case '%' : if ( c == esc ) { - octbuf[1] = esc; - } else { - chsize = 1; - } - break; - case '\v' : octbuf[1] = 'v'; break; - case '\t' : octbuf[1] = 't'; break; - case '\r' : octbuf[1] = 'r'; break; - case '\n' : octbuf[1] = 'n'; break; - case '\f' : octbuf[1] = 'f'; break; + case '\\' : /* FALLTHROUGH */ + case '%' : if ( c == esc ) { + octbuf[1] = esc; + } else { + chsize = 1; + } + break; + case '\v' : octbuf[1] = 'v'; break; + case '\t' : octbuf[1] = 't'; break; + case '\r' : octbuf[1] = 'r'; break; + case '\n' : octbuf[1] = 'n'; break; + case '\f' : octbuf[1] = 'f'; break; case '"' : if ( dq == '"' ) - octbuf[1] = '"'; + octbuf[1] = '"'; else chsize = 1; break; - default: + default: if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) { chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, isuni ? "%cx{%02" UVxf "}" : "%cx%02" UVxf, @@ -237,24 +237,24 @@ Perl_pv_escape( pTHX_ SV *dsv, char const * const str, } else { chsize = 1; } - } - if ( max && (wrote + chsize > max) ) { - break; + } + if ( max && (wrote + chsize > max) ) { + break; } else if (chsize > 1) { if (dsv) sv_catpvn(dsv, octbuf, chsize); wrote += chsize; - } else { - /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes - can be appended raw to the dsv. If dsv happens to be - UTF-8 then we need catpvf to upgrade them for us. - Or add a new API call sv_catpvc(). Think about that name, and - how to keep it clear that it's unlike the s of catpvs, which is - really an array of octets, not a string. */ + } else { + /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes + can be appended raw to the dsv. If dsv happens to be + UTF-8 then we need catpvf to upgrade them for us. + Or add a new API call sv_catpvc(). Think about that name, and + how to keep it clear that it's unlike the s of catpvs, which is + really an array of octets, not a string. */ if (dsv) Perl_sv_catpvf( aTHX_ dsv, "%c", c); - wrote++; - } + wrote++; + } if ( flags & PERL_PV_ESCAPE_FIRSTCHAR ) break; } @@ -335,7 +335,7 @@ Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]); if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) ) - sv_catpvs(dsv, "..."); + sv_catpvs(dsv, "..."); if ((flags & PERL_PV_PRETTY_EXACTSIZE)) { while( SvCUR(dsv) - orig_cur < max ) @@ -381,80 +381,80 @@ Perl_sv_peek(pTHX_ SV *sv) SvPVCLEAR(t); retry: if (!sv) { - sv_catpvs(t, "VOID"); - goto finish; + sv_catpvs(t, "VOID"); + goto finish; } else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') { /* detect data corruption under memory poisoning */ - sv_catpvs(t, "WILD"); - goto finish; + sv_catpvs(t, "WILD"); + goto finish; } else if ( sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_zero || sv == &PL_sv_placeholder) { - if (sv == &PL_sv_undef) { - sv_catpvs(t, "SV_UNDEF"); - if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - SvREADONLY(sv)) - goto finish; - } - else if (sv == &PL_sv_no) { - sv_catpvs(t, "SV_NO"); - if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| - SVp_POK|SVp_NOK)) && - SvCUR(sv) == 0 && - SvNVX(sv) == 0.0) - goto finish; - } - else if (sv == &PL_sv_yes) { - sv_catpvs(t, "SV_YES"); - if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| - SVp_POK|SVp_NOK)) && - SvCUR(sv) == 1 && - SvPVX_const(sv) && *SvPVX_const(sv) == '1' && - SvNVX(sv) == 1.0) - goto finish; - } - else if (sv == &PL_sv_zero) { - sv_catpvs(t, "SV_ZERO"); - if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| - SVp_POK|SVp_NOK)) && - SvCUR(sv) == 1 && - SvPVX_const(sv) && *SvPVX_const(sv) == '0' && - SvNVX(sv) == 0.0) - goto finish; - } - else { - sv_catpvs(t, "SV_PLACEHOLDER"); - if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| - SVs_GMG|SVs_SMG|SVs_RMG)) && - SvREADONLY(sv)) - goto finish; - } - sv_catpvs(t, ":"); + if (sv == &PL_sv_undef) { + sv_catpvs(t, "SV_UNDEF"); + if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + SvREADONLY(sv)) + goto finish; + } + else if (sv == &PL_sv_no) { + sv_catpvs(t, "SV_NO"); + if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| + SVp_POK|SVp_NOK)) && + SvCUR(sv) == 0 && + SvNVX(sv) == 0.0) + goto finish; + } + else if (sv == &PL_sv_yes) { + sv_catpvs(t, "SV_YES"); + if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| + SVp_POK|SVp_NOK)) && + SvCUR(sv) == 1 && + SvPVX_const(sv) && *SvPVX_const(sv) == '1' && + SvNVX(sv) == 1.0) + goto finish; + } + else if (sv == &PL_sv_zero) { + sv_catpvs(t, "SV_ZERO"); + if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| + SVp_POK|SVp_NOK)) && + SvCUR(sv) == 1 && + SvPVX_const(sv) && *SvPVX_const(sv) == '0' && + SvNVX(sv) == 0.0) + goto finish; + } + else { + sv_catpvs(t, "SV_PLACEHOLDER"); + if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| + SVs_GMG|SVs_SMG|SVs_RMG)) && + SvREADONLY(sv)) + goto finish; + } + sv_catpvs(t, ":"); } else if (SvREFCNT(sv) == 0) { - sv_catpvs(t, "("); - unref++; + sv_catpvs(t, "("); + unref++; } else if (DEBUG_R_TEST_) { - int is_tmp = 0; - SSize_t ix; - /* is this SV on the tmps stack? */ - for (ix=PL_tmps_ix; ix>=0; ix--) { - if (PL_tmps_stack[ix] == sv) { - is_tmp = 1; - break; - } - } - if (is_tmp || SvREFCNT(sv) > 1) { + int is_tmp = 0; + SSize_t ix; + /* is this SV on the tmps stack? */ + for (ix=PL_tmps_ix; ix>=0; ix--) { + if (PL_tmps_stack[ix] == sv) { + is_tmp = 1; + break; + } + } + if (is_tmp || SvREFCNT(sv) > 1) { Perl_sv_catpvf(aTHX_ t, "<"); if (SvREFCNT(sv) > 1) Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv)); @@ -465,15 +465,15 @@ Perl_sv_peek(pTHX_ SV *sv) } if (SvROK(sv)) { - sv_catpvs(t, "\\"); - if (SvCUR(t) + unref > 10) { - SvCUR_set(t, unref + 3); - *SvEND(t) = '\0'; - sv_catpvs(t, "..."); - goto finish; - } - sv = SvRV(sv); - goto retry; + sv_catpvs(t, "\\"); + if (SvCUR(t) + unref > 10) { + SvCUR_set(t, unref + 3); + *SvEND(t) = '\0'; + sv_catpvs(t, "..."); + goto finish; + } + sv = SvRV(sv); + goto retry; } type = SvTYPE(sv); if (type == SVt_PVCV) { @@ -482,56 +482,56 @@ Perl_sv_peek(pTHX_ SV *sv) Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv)) : ""); - goto finish; + goto finish; } else if (type < SVt_LAST) { - sv_catpv(t, svshorttypenames[type]); + sv_catpv(t, svshorttypenames[type]); - if (type == SVt_NULL) - goto finish; + if (type == SVt_NULL) + goto finish; } else { - sv_catpvs(t, "FREED"); - goto finish; + sv_catpvs(t, "FREED"); + goto finish; } if (SvPOKp(sv)) { - if (!SvPVX_const(sv)) - sv_catpvs(t, "(null)"); - else { - SV * const tmp = newSVpvs(""); - sv_catpvs(t, "("); - if (SvOOK(sv)) { - STRLEN delta; - SvOOK_offset(sv, delta); - Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127)); - } - Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127)); - if (SvUTF8(sv)) - Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]", - sv_uni_display(tmp, sv, 6 * SvCUR(sv), - UNI_DISPLAY_QQ)); - SvREFCNT_dec_NN(tmp); - } + if (!SvPVX_const(sv)) + sv_catpvs(t, "(null)"); + else { + SV * const tmp = newSVpvs(""); + sv_catpvs(t, "("); + if (SvOOK(sv)) { + STRLEN delta; + SvOOK_offset(sv, delta); + Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127)); + } + Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127)); + if (SvUTF8(sv)) + Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]", + sv_uni_display(tmp, sv, 6 * SvCUR(sv), + UNI_DISPLAY_QQ)); + SvREFCNT_dec_NN(tmp); + } } else if (SvNOKp(sv)) { DECLARATION_FOR_LC_NUMERIC_MANIPULATION; STORE_LC_NUMERIC_SET_STANDARD(); - Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv)); + Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv)); RESTORE_LC_NUMERIC(); } else if (SvIOKp(sv)) { - if (SvIsUV(sv)) - Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv)); - else + if (SvIsUV(sv)) + Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv)); + else Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv)); } else - sv_catpvs(t, "()"); + sv_catpvs(t, "()"); finish: while (unref--) - sv_catpvs(t, ")"); + sv_catpvs(t, ")"); if (TAINTING_get && sv && SvTAINTED(sv)) - sv_catpvs(t, " [tainted]"); + sv_catpvs(t, " [tainted]"); return SvPV_nolen(t); } @@ -609,7 +609,7 @@ S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file, } else - PerlIO_printf(file, " "); + PerlIO_printf(file, " "); for (i = level-1; i >= 0; i--) PerlIO_puts(file, @@ -660,7 +660,7 @@ Perl_dump_all_perl(pTHX_ bool justperl) { PerlIO_setlinebuf(Perl_debug_log); if (PL_main_root) - op_dump(PL_main_root); + op_dump(PL_main_root); dump_packsubs_perl(PL_defstash, justperl); } @@ -687,26 +687,26 @@ Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl) PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL; if (!HvARRAY(stash)) - return; + return; for (i = 0; i <= (I32) HvMAX(stash); i++) { const HE *entry; - for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { - GV * gv = (GV *)HeVAL(entry); + for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { + GV * gv = (GV *)HeVAL(entry); if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) /* unfake a fake GV */ (void)CvGV(SvRV(gv)); - if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) - continue; - if (GvCVu(gv)) - dump_sub_perl(gv, justperl); - if (GvFORM(gv)) - dump_form(gv); - if (HeKEY(entry)[HeKLEN(entry)-1] == ':') { - const HV * const hv = GvHV(gv); - if (hv && (hv != PL_defstash)) - dump_packsubs_perl(hv, justperl); /* nested package */ - } - } + if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) + continue; + if (GvCVu(gv)) + dump_sub_perl(gv, justperl); + if (GvFORM(gv)) + dump_form(gv); + if (HeKEY(entry)[HeKLEN(entry)-1] == ':') { + const HV * const hv = GvHV(gv); + if (hv && (hv != PL_defstash)) + dump_packsubs_perl(hv, justperl); /* nested package */ + } + } } } @@ -725,30 +725,30 @@ Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) PERL_ARGS_ASSERT_DUMP_SUB_PERL; cv = isGV_with_GP(gv) ? GvCV(gv) : - (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv)); + (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv)); if (justperl && (CvISXSUB(cv) || !CvROOT(cv))) - return; + return; if (isGV_with_GP(gv)) { - SV * const namesv = newSVpvs_flags("", SVs_TEMP); - SV *escsv = newSVpvs_flags("", SVs_TEMP); - const char *namepv; - STRLEN namelen; - gv_fullname3(namesv, gv, NULL); - namepv = SvPV_const(namesv, namelen); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", - generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv))); + SV * const namesv = newSVpvs_flags("", SVs_TEMP); + SV *escsv = newSVpvs_flags("", SVs_TEMP); + const char *namepv; + STRLEN namelen; + gv_fullname3(namesv, gv, NULL); + namepv = SvPV_const(namesv, namelen); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", + generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv))); } else { - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = "); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = "); } if (CvISXSUB(cv)) - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n", - PTR2UV(CvXSUB(cv)), - (int)CvXSUBANY(cv).any_i32); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n", + PTR2UV(CvXSUB(cv)), + (int)CvXSUBANY(cv).any_i32); else if (CvROOT(cv)) - op_dump(CvROOT(cv)); + op_dump(CvROOT(cv)); else - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); } void @@ -761,9 +761,9 @@ Perl_dump_form(pTHX_ const GV *gv) gv_fullname3(sv, gv, NULL); Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv)); if (CvROOT(GvFORM(gv))) - op_dump(CvROOT(GvFORM(gv))); + op_dump(CvROOT(GvFORM(gv))); else - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); } void @@ -815,23 +815,23 @@ S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm) UV kidbar; if (!pm) - return; + return; kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1; if (PM_GETRE(pm)) { char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/'; - S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n", - ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch); + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n", + ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch); } else - S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n"); + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n"); if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) { - SV * const tmpsv = pm_description(pm); - S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n", + SV * const tmpsv = pm_description(pm); + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); - SvREFCNT_dec_NN(tmpsv); + SvREFCNT_dec_NN(tmpsv); } if (pm->op_type == OP_SPLIT) @@ -841,21 +841,21 @@ S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm) else { if (pm->op_pmreplrootu.op_pmreplroot) { S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n"); - S_do_op_dump_bar(aTHX_ level + 2, + S_do_op_dump_bar(aTHX_ level + 2, (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))), file, pm->op_pmreplrootu.op_pmreplroot); } } if (pm->op_code_list) { - if (pm->op_pmflags & PMf_CODELIST_PRIVATE) { - S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n"); - S_do_op_dump_bar(aTHX_ level + 2, + if (pm->op_pmflags & PMf_CODELIST_PRIVATE) { + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n"); + S_do_op_dump_bar(aTHX_ level + 2, (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))), file, pm->op_code_list); - } - else - S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, + } + else + S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list)); } } @@ -892,7 +892,7 @@ S_pm_description(pTHX_ const PMOP *pm) PERL_ARGS_ASSERT_PM_DESCRIPTION; if (pmflags & PMf_ONCE) - sv_catpvs(desc, ",ONCE"); + sv_catpvs(desc, ",ONCE"); #ifdef USE_ITHREADS if (SvREADONLY(PL_regex_pad[pm->op_pmoffset])) sv_catpvs(desc, ":USED"); @@ -937,15 +937,15 @@ S_sequence_num(pTHX_ const OP *o) const char *key; STRLEN len; if (!o) - return 0; + return 0; op = newSVuv(PTR2UV(o)); sv_2mortal(op); key = SvPV_const(op, len); if (!PL_op_sequence) - PL_op_sequence = newHV(); + PL_op_sequence = newHV(); seq = hv_fetch(PL_op_sequence, key, len, 0); if (seq) - return SvUV(*seq); + return SvUV(*seq); (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0); return PL_op_seq; } @@ -1042,7 +1042,7 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) } if (o->op_targ && optype != OP_NULL) - S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n", + S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n", (long)o->op_targ); if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { @@ -1150,10 +1150,10 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv); } } - if (tmpsv && SvCUR(tmpsv)) { + if (tmpsv && SvCUR(tmpsv)) { S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); - } else + } else S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv); } @@ -1163,36 +1163,36 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) case OP_GVSV: case OP_GV: #ifdef USE_ITHREADS - S_opdump_indent(aTHX_ o, level, bar, file, + S_opdump_indent(aTHX_ o, level, bar, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); #else S_opdump_indent(aTHX_ o, level, bar, file, "GV = %" SVf " (0x%" UVxf ")\n", SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv)); #endif - break; + break; case OP_MULTIDEREF: { UNOP_AUX_item *items = cUNOP_AUXo->op_aux; UV i, count = items[-1].uv; - S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n"); + S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n"); for (i=0; i < count; i++) S_opdump_indent(aTHX_ o, level+1, (bar << 1), file, "%" UVuf " => 0x%" UVxf "\n", i, items[i].uv); - break; + break; } case OP_MULTICONCAT: - S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n", + S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n", (IV)cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].ssize); /* XXX really ought to dump each field individually, * but that's too much like hard work */ - S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n", + S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n", SVfARG(multiconcat_stringify(o))); - break; + break; case OP_CONST: case OP_HINTSEVAL: @@ -1201,21 +1201,21 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) case OP_METHOD_REDIR: case OP_METHOD_REDIR_SUPER: #ifndef USE_ITHREADS - /* with ITHREADS, consts are stored in the pad, and the right pad - * may not be active here, so skip */ - S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n", + /* with ITHREADS, consts are stored in the pad, and the right pad + * may not be active here, so skip */ + S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o))); #endif - break; + break; case OP_NULL: - if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE) - break; - /* FALLTHROUGH */ + if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE) + break; + /* FALLTHROUGH */ case OP_NEXTSTATE: case OP_DBSTATE: - if (CopLINE(cCOPo)) - S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n", - (UV)CopLINE(cCOPo)); + if (CopLINE(cCOPo)) + S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n", + (UV)CopLINE(cCOPo)); if (CopSTASHPV(cCOPo)) { SV* tmpsv = newSVpvs_flags("", SVs_TEMP); @@ -1240,17 +1240,17 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n", (unsigned int)cCOPo->cop_seq); - break; + break; case OP_ENTERITER: case OP_ENTERLOOP: - S_opdump_indent(aTHX_ o, level, bar, file, "REDO"); + S_opdump_indent(aTHX_ o, level, bar, file, "REDO"); S_opdump_link(aTHX_ o, cLOOPo->op_redoop, file); - S_opdump_indent(aTHX_ o, level, bar, file, "NEXT"); + S_opdump_indent(aTHX_ o, level, bar, file, "NEXT"); S_opdump_link(aTHX_ o, cLOOPo->op_nextop, file); - S_opdump_indent(aTHX_ o, level, bar, file, "LAST"); + S_opdump_indent(aTHX_ o, level, bar, file, "LAST"); S_opdump_link(aTHX_ o, cLOOPo->op_lastop, file); - break; + break; case OP_REGCOMP: case OP_SUBSTCONT: @@ -1269,33 +1269,33 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) case OP_ENTERWHEN: case OP_ENTERTRY: case OP_ONCE: - S_opdump_indent(aTHX_ o, level, bar, file, "OTHER"); + S_opdump_indent(aTHX_ o, level, bar, file, "OTHER"); S_opdump_link(aTHX_ o, cLOGOPo->op_other, file); - break; + break; case OP_SPLIT: case OP_MATCH: case OP_QR: case OP_SUBST: - S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo); - break; + S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo); + break; case OP_LEAVE: case OP_LEAVEEVAL: case OP_LEAVESUB: case OP_LEAVESUBLV: case OP_LEAVEWRITE: case OP_SCOPE: - if (o->op_private & OPpREFCOUNTED) - S_opdump_indent(aTHX_ o, level, bar, file, + if (o->op_private & OPpREFCOUNTED) + S_opdump_indent(aTHX_ o, level, bar, file, "REFCNT = %" UVuf "\n", (UV)o->op_targ); - break; + break; case OP_DUMP: case OP_GOTO: case OP_NEXT: case OP_LAST: case OP_REDO: - if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) - break; + if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) + break; { SV * const label = newSVpvs_flags("", SVs_TEMP); generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0); @@ -1310,8 +1310,8 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) if (o->op_private & OPpTRANS_USE_SVOP) { /* utf8: table stored as an inversion map */ #ifndef USE_ITHREADS - /* with ITHREADS, it is stored in the pad, and the right pad - * may not be active here, so skip */ + /* with ITHREADS, it is stored in the pad, and the right pad + * may not be active here, so skip */ S_opdump_indent(aTHX_ o, level, bar, file, "INVMAP = 0x%" UVxf "\n", PTR2UV(MUTABLE_SV(cSVOPo->op_sv))); @@ -1346,14 +1346,14 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) default: - break; + break; } if (o->op_flags & OPf_KIDS) { - OP *kid; + OP *kid; level++; bar <<= 1; - for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) - S_do_op_dump_bar(aTHX_ level, + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) + S_do_op_dump_bar(aTHX_ level, (bar | cBOOL(OpHAS_SIBLING(kid))), file, kid); } @@ -1390,8 +1390,8 @@ Perl_gv_dump(pTHX_ GV *gv) SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP); if (!gv) { - PerlIO_printf(Perl_debug_log, "{}\n"); - return; + PerlIO_printf(Perl_debug_log, "{}\n"); + return; } sv = sv_newmortal(); PerlIO_printf(Perl_debug_log, "{\n"); @@ -1400,7 +1400,7 @@ Perl_gv_dump(pTHX_ GV *gv) Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", generic_pv_escape( tmp, name, len, SvUTF8(sv) )); if (gv != GvEGV(gv)) { - gv_efullname3(sv, GvEGV(gv), NULL); + gv_efullname3(sv, GvEGV(gv), NULL); name = SvPV_const(sv, len); Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", generic_pv_escape( tmp, name, len, SvUTF8(sv) )); @@ -1416,8 +1416,8 @@ Perl_gv_dump(pTHX_ GV *gv) static const struct { const char type; const char *name; } magic_names[] = { #include "mg_names.inc" - /* this null string terminates the list */ - { 0, NULL }, + /* this null string terminates the list */ + { 0, NULL }, }; void @@ -1427,120 +1427,120 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 for (; mg; mg = mg->mg_moremagic) { Perl_dump_indent(aTHX_ level, file, - " MAGIC = 0x%" UVxf "\n", PTR2UV(mg)); + " MAGIC = 0x%" UVxf "\n", PTR2UV(mg)); if (mg->mg_virtual) { const MGVTBL * const v = mg->mg_virtual; - if (v >= PL_magic_vtables - && v < PL_magic_vtables + magic_vtable_max) { - const U32 i = v - PL_magic_vtables; - Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]); - } - else - Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%" + if (v >= PL_magic_vtables + && v < PL_magic_vtables + magic_vtable_max) { + const U32 i = v - PL_magic_vtables; + Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]); + } + else + Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%" UVxf "\n", PTR2UV(v)); } - else - Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n"); - - if (mg->mg_private) - Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private); - - { - int n; - const char *name = NULL; - for (n = 0; magic_names[n].name; n++) { - if (mg->mg_type == magic_names[n].type) { - name = magic_names[n].name; - break; - } - } - if (name) - Perl_dump_indent(aTHX_ level, file, - " MG_TYPE = PERL_MAGIC_%s\n", name); - else - Perl_dump_indent(aTHX_ level, file, - " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type); - } + else + Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n"); + + if (mg->mg_private) + Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private); + + { + int n; + const char *name = NULL; + for (n = 0; magic_names[n].name; n++) { + if (mg->mg_type == magic_names[n].type) { + name = magic_names[n].name; + break; + } + } + if (name) + Perl_dump_indent(aTHX_ level, file, + " MG_TYPE = PERL_MAGIC_%s\n", name); + else + Perl_dump_indent(aTHX_ level, file, + " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type); + } if (mg->mg_flags) { Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags); - if (mg->mg_type == PERL_MAGIC_envelem && - mg->mg_flags & MGf_TAINTEDDIR) - Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n"); - if (mg->mg_type == PERL_MAGIC_regex_global && - mg->mg_flags & MGf_MINMATCH) - Perl_dump_indent(aTHX_ level, file, " MINMATCH\n"); - if (mg->mg_flags & MGf_REFCOUNTED) - Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n"); + if (mg->mg_type == PERL_MAGIC_envelem && + mg->mg_flags & MGf_TAINTEDDIR) + Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n"); + if (mg->mg_type == PERL_MAGIC_regex_global && + mg->mg_flags & MGf_MINMATCH) + Perl_dump_indent(aTHX_ level, file, " MINMATCH\n"); + if (mg->mg_flags & MGf_REFCOUNTED) + Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n"); if (mg->mg_flags & MGf_GSKIP) - Perl_dump_indent(aTHX_ level, file, " GSKIP\n"); - if (mg->mg_flags & MGf_COPY) - Perl_dump_indent(aTHX_ level, file, " COPY\n"); - if (mg->mg_flags & MGf_DUP) - Perl_dump_indent(aTHX_ level, file, " DUP\n"); - if (mg->mg_flags & MGf_LOCAL) - Perl_dump_indent(aTHX_ level, file, " LOCAL\n"); - if (mg->mg_type == PERL_MAGIC_regex_global && - mg->mg_flags & MGf_BYTES) - Perl_dump_indent(aTHX_ level, file, " BYTES\n"); + Perl_dump_indent(aTHX_ level, file, " GSKIP\n"); + if (mg->mg_flags & MGf_COPY) + Perl_dump_indent(aTHX_ level, file, " COPY\n"); + if (mg->mg_flags & MGf_DUP) + Perl_dump_indent(aTHX_ level, file, " DUP\n"); + if (mg->mg_flags & MGf_LOCAL) + Perl_dump_indent(aTHX_ level, file, " LOCAL\n"); + if (mg->mg_type == PERL_MAGIC_regex_global && + mg->mg_flags & MGf_BYTES) + Perl_dump_indent(aTHX_ level, file, " BYTES\n"); } - if (mg->mg_obj) { - Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n", - PTR2UV(mg->mg_obj)); + if (mg->mg_obj) { + Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n", + PTR2UV(mg->mg_obj)); if (mg->mg_type == PERL_MAGIC_qr) { - REGEXP* const re = (REGEXP *)mg->mg_obj; - SV * const dsv = sv_newmortal(); + REGEXP* const re = (REGEXP *)mg->mg_obj; + SV * const dsv = sv_newmortal(); const char * const s - = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re), + = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re), 60, NULL, NULL, ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES | (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0)) ); - Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s); - Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n", - (IV)RX_REFCNT(re)); + Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s); + Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n", + (IV)RX_REFCNT(re)); } if (mg->mg_flags & MGf_REFCOUNTED) - do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ - } + do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ + } if (mg->mg_len) - Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len); + Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len); if (mg->mg_ptr) { - Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr)); - if (mg->mg_len >= 0) { - if (mg->mg_type != PERL_MAGIC_utf8) { - SV * const sv = newSVpvs(""); - PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim)); - SvREFCNT_dec_NN(sv); - } + Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr)); + if (mg->mg_len >= 0) { + if (mg->mg_type != PERL_MAGIC_utf8) { + SV * const sv = newSVpvs(""); + PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim)); + SvREFCNT_dec_NN(sv); + } + } + else if (mg->mg_len == HEf_SVKEY) { + PerlIO_puts(file, " => HEf_SVKEY\n"); + do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1, + maxnest, dumpops, pvlim); /* MG is already +1 */ + continue; } - else if (mg->mg_len == HEf_SVKEY) { - PerlIO_puts(file, " => HEf_SVKEY\n"); - do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1, - maxnest, dumpops, pvlim); /* MG is already +1 */ - continue; - } - else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8); - else - PerlIO_puts( - file, - " ???? - " __FILE__ - " does not know how to handle this MG_LEN" - ); + else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8); + else + PerlIO_puts( + file, + " ???? - " __FILE__ + " does not know how to handle this MG_LEN" + ); (void)PerlIO_putc(file, '\n'); } - if (mg->mg_type == PERL_MAGIC_utf8) { - const STRLEN * const cache = (STRLEN *) mg->mg_ptr; - if (cache) { - IV i; - for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++) - Perl_dump_indent(aTHX_ level, file, - " %2" IVdf ": %" UVuf " -> %" UVuf "\n", - i, - (UV)cache[i * 2], - (UV)cache[i * 2 + 1]); - } - } + if (mg->mg_type == PERL_MAGIC_utf8) { + const STRLEN * const cache = (STRLEN *) mg->mg_ptr; + if (cache) { + IV i; + for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++) + Perl_dump_indent(aTHX_ level, file, + " %2" IVdf ": %" UVuf " -> %" UVuf "\n", + i, + (UV)cache[i * 2], + (UV)cache[i * 2 + 1]); + } + } } } @@ -1560,7 +1560,7 @@ Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv)); if (sv && (hvname = HvNAME_get(sv))) { - /* we have to use pv_display and HvNAMELEN_get() so that we display the real package + /* we have to use pv_display and HvNAMELEN_get() so that we display the real package name which quite legally could contain insane things like tabs, newlines, nulls or other scary crap - this should produce sane results - except maybe for unicode package names - but we will wait for someone to file a bug on that - demerphq */ @@ -1596,11 +1596,11 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv)); if (sv && GvNAME(sv)) { SV *tmp = newSVpvs_flags("", SVs_TEMP); - const char *hvname; + const char *hvname; HV * const stash = GvSTASH(sv); - PerlIO_printf(file, "\t"); + PerlIO_printf(file, "\t"); /* TODO might have an extra \" here */ - if (stash && (hvname = HvNAME_get(stash))) { + if (stash && (hvname = HvNAME_get(stash))) { PerlIO_printf(file, "\"%s\" :: \"", generic_pv_escape(tmp, hvname, HvNAMELEN(stash), HvNAMEUTF8(stash))); @@ -1743,8 +1743,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo PERL_ARGS_ASSERT_DO_SV_DUMP; if (!sv) { - Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); - return; + Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); + return; } flags = SvFLAGS(sv); @@ -1753,28 +1753,28 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo /* process general SV flags */ d = Perl_newSVpvf(aTHX_ - "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (", - PTR2UV(SvANY(sv)), PTR2UV(sv), - (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), - (int)(PL_dumpindent*level), ""); + "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (", + PTR2UV(SvANY(sv)), PTR2UV(sv), + (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), + (int)(PL_dumpindent*level), ""); if ((flags & SVs_PADSTALE)) - sv_catpvs(d, "PADSTALE,"); + sv_catpvs(d, "PADSTALE,"); if ((flags & SVs_PADTMP)) - sv_catpvs(d, "PADTMP,"); + sv_catpvs(d, "PADTMP,"); append_flags(d, flags, first_sv_flags_names); if (flags & SVf_ROK) { sv_catpvs(d, "ROK,"); - if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,"); + if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,"); } if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,"); append_flags(d, flags, second_sv_flags_names); if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv) - && type != SVt_PVAV) { - if (SvPCS_IMPORTED(sv)) - sv_catpvs(d, "PCS_IMPORTED,"); - else - sv_catpvs(d, "SCREAM,"); + && type != SVt_PVAV) { + if (SvPCS_IMPORTED(sv)) + sv_catpvs(d, "PCS_IMPORTED,"); + else + sv_catpvs(d, "SCREAM,"); } /* process type-specific SV flags */ @@ -1782,34 +1782,34 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo switch (type) { case SVt_PVCV: case SVt_PVFM: - append_flags(d, CvFLAGS(sv), cv_flags_names); - break; + append_flags(d, CvFLAGS(sv), cv_flags_names); + break; case SVt_PVHV: - append_flags(d, flags, hv_flags_names); - break; + append_flags(d, flags, hv_flags_names); + break; case SVt_PVGV: case SVt_PVLV: - if (isGV_with_GP(sv)) { - append_flags(d, GvFLAGS(sv), gp_flags_names); - } - if (isGV_with_GP(sv) && GvIMPORTED(sv)) { - sv_catpvs(d, "IMPORT"); - if (GvIMPORTED(sv) == GVf_IMPORTED) - sv_catpvs(d, "ALL,"); - else { - sv_catpvs(d, "("); - append_flags(d, GvFLAGS(sv), gp_flags_imported_names); - sv_catpvs(d, " ),"); - } - } - /* FALLTHROUGH */ + if (isGV_with_GP(sv)) { + append_flags(d, GvFLAGS(sv), gp_flags_names); + } + if (isGV_with_GP(sv) && GvIMPORTED(sv)) { + sv_catpvs(d, "IMPORT"); + if (GvIMPORTED(sv) == GVf_IMPORTED) + sv_catpvs(d, "ALL,"); + else { + sv_catpvs(d, "("); + append_flags(d, GvFLAGS(sv), gp_flags_imported_names); + sv_catpvs(d, " ),"); + } + } + /* FALLTHROUGH */ case SVt_PVMG: default: - if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,"); - break; + if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,"); + break; case SVt_PVAV: - break; + break; } /* SVphv_SHAREKEYS is also 0x20000000 */ if ((type != SVt_PVHV) && SvUTF8(sv)) @@ -1817,7 +1817,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo if (*(SvEND(d) - 1) == ',') { SvCUR_set(d, SvCUR(d) - 1); - SvPVX(d)[SvCUR(d)] = '\0'; + SvPVX(d)[SvCUR(d)] = '\0'; } sv_catpvs(d, ")"); s = SvPVX_const(d); @@ -1826,13 +1826,13 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo #ifdef DEBUG_LEAKING_SCALARS Perl_dump_indent(aTHX_ level, file, - "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n", - sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", - sv->sv_debug_line, - sv->sv_debug_inpad ? "for" : "by", - sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", - PTR2UV(sv->sv_debug_parent), - sv->sv_debug_serial + "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n", + sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", + sv->sv_debug_line, + sv->sv_debug_inpad ? "for" : "by", + sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", + PTR2UV(sv->sv_debug_parent), + sv->sv_debug_serial ); #endif Perl_dump_indent(aTHX_ level, file, "SV = "); @@ -1840,77 +1840,77 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo /* Dump SV type */ if (type < SVt_LAST) { - PerlIO_printf(file, "%s%s\n", svtypenames[type], s); + PerlIO_printf(file, "%s%s\n", svtypenames[type], s); - if (type == SVt_NULL) { - SvREFCNT_dec_NN(d); - return; - } + if (type == SVt_NULL) { + SvREFCNT_dec_NN(d); + return; + } } else { - PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s); - SvREFCNT_dec_NN(d); - return; + PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s); + SvREFCNT_dec_NN(d); + return; } /* Dump general SV fields */ if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV - && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO - && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv)) - || (type == SVt_IV && !SvROK(sv))) { - if (SvIsUV(sv) - ) - Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv)); - else - Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv)); - (void)PerlIO_putc(file, '\n'); + && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO + && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv)) + || (type == SVt_IV && !SvROK(sv))) { + if (SvIsUV(sv) + ) + Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv)); + else + Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv)); + (void)PerlIO_putc(file, '\n'); } if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV - && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP - && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv)) - || type == SVt_NV) { + && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP + && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv)) + || type == SVt_NV) { DECLARATION_FOR_LC_NUMERIC_MANIPULATION; STORE_LC_NUMERIC_SET_STANDARD(); - Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv)); + Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv)); RESTORE_LC_NUMERIC(); } if (SvROK(sv)) { - Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n", + Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n", PTR2UV(SvRV(sv))); - if (nest < maxnest) - do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim); + if (nest < maxnest) + do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim); } if (type < SVt_PV) { - SvREFCNT_dec_NN(d); - return; + SvREFCNT_dec_NN(d); + return; } if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) { - const bool re = isREGEXP(sv); - const char * const ptr = - re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); - if (ptr) { - STRLEN delta; - if (SvOOK(sv)) { - SvOOK_offset(sv, delta); - Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n", - (UV) delta); - } else { - delta = 0; - } - Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ", + const bool re = isREGEXP(sv); + const char * const ptr = + re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); + if (ptr) { + STRLEN delta; + if (SvOOK(sv)) { + SvOOK_offset(sv, delta); + Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n", + (UV) delta); + } else { + delta = 0; + } + Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ", PTR2UV(ptr)); - if (SvOOK(sv)) { - PerlIO_printf(file, "( %s . ) ", - pv_display(d, ptr - delta, delta, 0, - pvlim)); - } + if (SvOOK(sv)) { + PerlIO_printf(file, "( %s . ) ", + pv_display(d, ptr - delta, delta, 0, + pvlim)); + } if (type == SVt_INVLIST) { - PerlIO_printf(file, "\n"); + PerlIO_printf(file, "\n"); /* 4 blanks indents 2 beyond the PV, etc */ _invlist_dump(file, level, " ", sv); } @@ -1924,139 +1924,139 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo UNI_DISPLAY_QQ)); PerlIO_printf(file, "\n"); } - Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv)); - if (re && type == SVt_PVLV) + Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv)); + if (re && type == SVt_PVLV) /* LV-as-REGEXP usurps len field to store pointer to * regexp struct */ - Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n", + Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n", PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx)); else - Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n", - (IV)SvLEN(sv)); + Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n", + (IV)SvLEN(sv)); #ifdef PERL_COPY_ON_WRITE - if (SvIsCOW(sv) && SvLEN(sv)) - Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n", - CowREFCNT(sv)); + if (SvIsCOW(sv) && SvLEN(sv)) + Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n", + CowREFCNT(sv)); #endif - } - else - Perl_dump_indent(aTHX_ level, file, " PV = 0\n"); + } + else + Perl_dump_indent(aTHX_ level, file, " PV = 0\n"); } if (type >= SVt_PVMG) { - if (SvMAGIC(sv)) - do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim); - if (SvSTASH(sv)) - do_hv_dump(level, file, " STASH", SvSTASH(sv)); + if (SvMAGIC(sv)) + do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim); + if (SvSTASH(sv)) + do_hv_dump(level, file, " STASH", SvSTASH(sv)); - if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) { - Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n", + if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) { + Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n", (IV)BmUSEFUL(sv)); - } + } } /* Dump type-specific SV fields */ switch (type) { case SVt_PVAV: - Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, + Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(AvARRAY(sv))); - if (AvARRAY(sv) != AvALLOC(sv)) { - PerlIO_printf(file, " (offset=%" IVdf ")\n", + if (AvARRAY(sv) != AvALLOC(sv)) { + PerlIO_printf(file, " (offset=%" IVdf ")\n", (IV)(AvARRAY(sv) - AvALLOC(sv))); - Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n", + Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n", PTR2UV(AvALLOC(sv))); - } - else + } + else (void)PerlIO_putc(file, '\n'); - Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n", + Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n", (IV)AvFILLp(sv)); - Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", + Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", (IV)AvMAX(sv)); SvPVCLEAR(d); - if (AvREAL(sv)) sv_catpvs(d, ",REAL"); - if (AvREIFY(sv)) sv_catpvs(d, ",REIFY"); - Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", - SvCUR(d) ? SvPVX_const(d) + 1 : ""); - if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) { - SSize_t count; + if (AvREAL(sv)) sv_catpvs(d, ",REAL"); + if (AvREIFY(sv)) sv_catpvs(d, ",REIFY"); + Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", + SvCUR(d) ? SvPVX_const(d) + 1 : ""); + if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) { + SSize_t count; SV **svp = AvARRAY(MUTABLE_AV(sv)); - for (count = 0; + for (count = 0; count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest; count++, svp++) { - SV* const elt = *svp; - Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n", + SV* const elt = *svp; + Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n", (IV)count); do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); - } - } - break; + } + } + break; case SVt_PVHV: { - U32 usedkeys; + U32 usedkeys; if (SvOOK(sv)) { struct xpvhv_aux *const aux = HvAUX(sv); Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n", (UV)aux->xhv_aux_flags); } - Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv))); - usedkeys = HvUSEDKEYS(MUTABLE_HV(sv)); - if (HvARRAY(sv) && usedkeys) { - /* Show distribution of HEs in the ARRAY */ - int freq[200]; + Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv))); + usedkeys = HvUSEDKEYS(MUTABLE_HV(sv)); + if (HvARRAY(sv) && usedkeys) { + /* Show distribution of HEs in the ARRAY */ + int freq[200]; #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1)) - int i; - int max = 0; - U32 pow2 = 2, keys = usedkeys; - NV theoret, sum = 0; - - PerlIO_printf(file, " ("); - Zero(freq, FREQ_MAX + 1, int); - for (i = 0; (STRLEN)i <= HvMAX(sv); i++) { - HE* h; - int count = 0; + int i; + int max = 0; + U32 pow2 = 2, keys = usedkeys; + NV theoret, sum = 0; + + PerlIO_printf(file, " ("); + Zero(freq, FREQ_MAX + 1, int); + for (i = 0; (STRLEN)i <= HvMAX(sv); i++) { + HE* h; + int count = 0; for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h)) - count++; - if (count > FREQ_MAX) - count = FREQ_MAX; - freq[count]++; - if (max < count) - max = count; - } - for (i = 0; i <= max; i++) { - if (freq[i]) { - PerlIO_printf(file, "%d%s:%d", i, - (i == FREQ_MAX) ? "+" : "", - freq[i]); - if (i != max) - PerlIO_printf(file, ", "); - } + count++; + if (count > FREQ_MAX) + count = FREQ_MAX; + freq[count]++; + if (max < count) + max = count; + } + for (i = 0; i <= max; i++) { + if (freq[i]) { + PerlIO_printf(file, "%d%s:%d", i, + (i == FREQ_MAX) ? "+" : "", + freq[i]); + if (i != max) + PerlIO_printf(file, ", "); + } } - (void)PerlIO_putc(file, ')'); - /* The "quality" of a hash is defined as the total number of - comparisons needed to access every element once, relative - to the expected number needed for a random hash. - - The total number of comparisons is equal to the sum of - the squares of the number of entries in each bucket. - For a random hash of n keys into k buckets, the expected - value is - n + n(n-1)/2k - */ - - for (i = max; i > 0; i--) { /* Precision: count down. */ - sum += freq[i] * i * i; + (void)PerlIO_putc(file, ')'); + /* The "quality" of a hash is defined as the total number of + comparisons needed to access every element once, relative + to the expected number needed for a random hash. + + The total number of comparisons is equal to the sum of + the squares of the number of entries in each bucket. + For a random hash of n keys into k buckets, the expected + value is + n + n(n-1)/2k + */ + + for (i = max; i > 0; i--) { /* Precision: count down. */ + sum += freq[i] * i * i; } - while ((keys = keys >> 1)) - pow2 = pow2 << 1; - theoret = usedkeys; - theoret += theoret * (theoret-1)/pow2; - (void)PerlIO_putc(file, '\n'); - Perl_dump_indent(aTHX_ level, file, " hash quality = %.1" + while ((keys = keys >> 1)) + pow2 = pow2 << 1; + theoret = usedkeys; + theoret += theoret * (theoret-1)/pow2; + (void)PerlIO_putc(file, '\n'); + Perl_dump_indent(aTHX_ level, file, " hash quality = %.1" NVff "%%", theoret/sum*100); - } - (void)PerlIO_putc(file, '\n'); - Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n", + } + (void)PerlIO_putc(file, '\n'); + Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n", (IV)usedkeys); { STRLEN count = 0; @@ -2075,15 +2075,15 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n", (UV)count); } - Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", + Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", (IV)HvMAX(sv)); if (SvOOK(sv)) { - Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n", + Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n", (IV)HvRITER_get(sv)); - Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n", + Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n", PTR2UV(HvEITER_get(sv))); #ifdef PERL_HASH_RANDOMIZE_KEYS - Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf, + Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf, (UV)HvRAND_get(sv)); if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) { PerlIO_printf(file, " (LAST = 0x%" UVxf ")", @@ -2092,254 +2092,254 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo #endif (void)PerlIO_putc(file, '\n'); } - { - MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab); - if (mg && mg->mg_obj) { - Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj)); - } - } - { - const char * const hvname = HvNAME_get(sv); - if (hvname) { + { + MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab); + if (mg && mg->mg_obj) { + Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj)); + } + } + { + const char * const hvname = HvNAME_get(sv); + if (hvname) { SV* tmpsv = newSVpvs_flags("", SVs_TEMP); Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", generic_pv_escape( tmpsv, hvname, HvNAMELEN(sv), HvNAMEUTF8(sv))); } - } - if (SvOOK(sv)) { - AV * const backrefs - = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv)); - struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta; - if (HvAUX(sv)->xhv_name_count) - Perl_dump_indent(aTHX_ - level, file, " NAMECOUNT = %" IVdf "\n", - (IV)HvAUX(sv)->xhv_name_count - ); - if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) { - const I32 count = HvAUX(sv)->xhv_name_count; - if (count) { - SV * const names = newSVpvs_flags("", SVs_TEMP); - /* The starting point is the first element if count is - positive and the second element if count is negative. */ - HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names - + (count < 0 ? 1 : 0); - HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names - + (count < 0 ? -count : count); - while (hekp < endp) { - if (*hekp) { + } + if (SvOOK(sv)) { + AV * const backrefs + = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv)); + struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta; + if (HvAUX(sv)->xhv_name_count) + Perl_dump_indent(aTHX_ + level, file, " NAMECOUNT = %" IVdf "\n", + (IV)HvAUX(sv)->xhv_name_count + ); + if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) { + const I32 count = HvAUX(sv)->xhv_name_count; + if (count) { + SV * const names = newSVpvs_flags("", SVs_TEMP); + /* The starting point is the first element if count is + positive and the second element if count is negative. */ + HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names + + (count < 0 ? 1 : 0); + HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names + + (count < 0 ? -count : count); + while (hekp < endp) { + if (*hekp) { SV *tmp = newSVpvs_flags("", SVs_TEMP); - Perl_sv_catpvf(aTHX_ names, ", \"%s\"", + Perl_sv_catpvf(aTHX_ names, ", \"%s\"", generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp))); - } else { - /* This should never happen. */ - sv_catpvs(names, ", (null)"); - } - ++hekp; - } - Perl_dump_indent(aTHX_ - level, file, " ENAME = %s\n", SvPV_nolen(names)+2 - ); - } - else { + } else { + /* This should never happen. */ + sv_catpvs(names, ", (null)"); + } + ++hekp; + } + Perl_dump_indent(aTHX_ + level, file, " ENAME = %s\n", SvPV_nolen(names)+2 + ); + } + else { SV * const tmp = newSVpvs_flags("", SVs_TEMP); const char *const hvename = HvENAME_get(sv); - Perl_dump_indent(aTHX_ - level, file, " ENAME = \"%s\"\n", + Perl_dump_indent(aTHX_ + level, file, " ENAME = \"%s\"\n", generic_pv_escape(tmp, hvename, HvENAMELEN_get(sv), HvENAMEUTF8(sv))); } - } - if (backrefs) { - Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n", - PTR2UV(backrefs)); - do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest, - dumpops, pvlim); - } - if (meta) { - SV* tmpsv = newSVpvs_flags("", SVs_TEMP); - Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%" + } + if (backrefs) { + Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n", + PTR2UV(backrefs)); + do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest, + dumpops, pvlim); + } + if (meta) { + SV* tmpsv = newSVpvs_flags("", SVs_TEMP); + Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%" UVxf ")\n", - generic_pv_escape( tmpsv, meta->mro_which->name, + generic_pv_escape( tmpsv, meta->mro_which->name, meta->mro_which->length, (meta->mro_which->kflags & HVhek_UTF8)), - PTR2UV(meta->mro_which)); - Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%" + PTR2UV(meta->mro_which)); + Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%" UVxf "\n", - (UV)meta->cache_gen); - Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n", - (UV)meta->pkg_gen); - if (meta->mro_linear_all) { - Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%" + (UV)meta->cache_gen); + Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n", + (UV)meta->pkg_gen); + if (meta->mro_linear_all) { + Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%" UVxf "\n", - PTR2UV(meta->mro_linear_all)); - do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest, - dumpops, pvlim); - } - if (meta->mro_linear_current) { - Perl_dump_indent(aTHX_ level, file, + PTR2UV(meta->mro_linear_all)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest, + dumpops, pvlim); + } + if (meta->mro_linear_current) { + Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%" UVxf "\n", - PTR2UV(meta->mro_linear_current)); - do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest, - dumpops, pvlim); - } - if (meta->mro_nextmethod) { - Perl_dump_indent(aTHX_ level, file, + PTR2UV(meta->mro_linear_current)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest, + dumpops, pvlim); + } + if (meta->mro_nextmethod) { + Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%" UVxf "\n", - PTR2UV(meta->mro_nextmethod)); - do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest, - dumpops, pvlim); - } - if (meta->isa) { - Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n", - PTR2UV(meta->isa)); - do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest, - dumpops, pvlim); - } - } - } - if (nest < maxnest) { - HV * const hv = MUTABLE_HV(sv); - STRLEN i; - HE *he; - - if (HvARRAY(hv)) { - int count = maxnest - nest; - for (i=0; i <= HvMAX(hv); i++) { - for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) { - U32 hash; - SV * keysv; - const char * keypv; - SV * elt; + PTR2UV(meta->mro_nextmethod)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest, + dumpops, pvlim); + } + if (meta->isa) { + Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n", + PTR2UV(meta->isa)); + do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest, + dumpops, pvlim); + } + } + } + if (nest < maxnest) { + HV * const hv = MUTABLE_HV(sv); + STRLEN i; + HE *he; + + if (HvARRAY(hv)) { + int count = maxnest - nest; + for (i=0; i <= HvMAX(hv); i++) { + for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) { + U32 hash; + SV * keysv; + const char * keypv; + SV * elt; STRLEN len; - if (count-- <= 0) goto DONEHV; + if (count-- <= 0) goto DONEHV; - hash = HeHASH(he); - keysv = hv_iterkeysv(he); - keypv = SvPV_const(keysv, len); - elt = HeVAL(he); + hash = HeHASH(he); + keysv = hv_iterkeysv(he); + keypv = SvPV_const(keysv, len); + elt = HeVAL(he); Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim)); if (SvUTF8(keysv)) PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ)); - if (HvEITER_get(hv) == he) - PerlIO_printf(file, "[CURRENT] "); + if (HvEITER_get(hv) == he) + PerlIO_printf(file, "[CURRENT] "); PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash); do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); } - } - DONEHV:; - } - } - break; + } + DONEHV:; + } + } + break; } /* case SVt_PVHV */ case SVt_PVCV: - if (CvAUTOLOAD(sv)) { - SV* tmpsv = newSVpvs_flags("", SVs_TEMP); + if (CvAUTOLOAD(sv)) { + SV* tmpsv = newSVpvs_flags("", SVs_TEMP); STRLEN len; - const char *const name = SvPV_const(sv, len); - Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n", - generic_pv_escape(tmpsv, name, len, SvUTF8(sv))); - } - if (SvPOK(sv)) { + const char *const name = SvPV_const(sv, len); + Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n", + generic_pv_escape(tmpsv, name, len, SvUTF8(sv))); + } + if (SvPOK(sv)) { SV* tmpsv = newSVpvs_flags("", SVs_TEMP); const char *const proto = CvPROTO(sv); - Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", - generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv), + Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", + generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv), SvUTF8(sv))); - } - /* FALLTHROUGH */ + } + /* FALLTHROUGH */ case SVt_PVFM: - do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); - if (!CvISXSUB(sv)) { - if (CvSTART(sv)) { + do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); + if (!CvISXSUB(sv)) { + if (CvSTART(sv)) { if (CvSLABBED(sv)) Perl_dump_indent(aTHX_ level, file, - " SLAB = 0x%" UVxf "\n", - PTR2UV(CvSTART(sv))); + " SLAB = 0x%" UVxf "\n", + PTR2UV(CvSTART(sv))); else Perl_dump_indent(aTHX_ level, file, - " START = 0x%" UVxf " ===> %" IVdf "\n", - PTR2UV(CvSTART(sv)), - (IV)sequence_num(CvSTART(sv))); - } - Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n", - PTR2UV(CvROOT(sv))); - if (CvROOT(sv) && dumpops) { - do_op_dump(level+1, file, CvROOT(sv)); - } - } else { - SV * const constant = cv_const_sv((const CV *)sv); - - Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv))); - - if (constant) { - Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf - " (CONST SV)\n", - PTR2UV(CvXSUBANY(sv).any_ptr)); - do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops, - pvlim); - } else { - Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n", - (IV)CvXSUBANY(sv).any_i32); - } - } - if (CvNAMED(sv)) - Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", - HEK_KEY(CvNAME_HEK((CV *)sv))); - else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); - Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); - Perl_dump_indent(aTHX_ level, file, " DEPTH = %" + " START = 0x%" UVxf " ===> %" IVdf "\n", + PTR2UV(CvSTART(sv)), + (IV)sequence_num(CvSTART(sv))); + } + Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n", + PTR2UV(CvROOT(sv))); + if (CvROOT(sv) && dumpops) { + do_op_dump(level+1, file, CvROOT(sv)); + } + } else { + SV * const constant = cv_const_sv((const CV *)sv); + + Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv))); + + if (constant) { + Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf + " (CONST SV)\n", + PTR2UV(CvXSUBANY(sv).any_ptr)); + do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops, + pvlim); + } else { + Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n", + (IV)CvXSUBANY(sv).any_i32); + } + } + if (CvNAMED(sv)) + Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", + HEK_KEY(CvNAME_HEK((CV *)sv))); + else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); + Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); + Perl_dump_indent(aTHX_ level, file, " DEPTH = %" IVdf "\n", (IV)CvDEPTH(sv)); - Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", + Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)CvFLAGS(sv)); - Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv)); - if (!CvISXSUB(sv)) { - Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv))); - if (nest < maxnest) { - do_dump_pad(level+1, file, CvPADLIST(sv), 0); - } - } - else - Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv)); - { - const CV * const outside = CvOUTSIDE(sv); - Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n", - PTR2UV(outside), - (!outside ? "null" - : CvANON(outside) ? "ANON" - : (outside == PL_main_cv) ? "MAIN" - : CvUNIQUE(outside) ? "UNIQUE" - : CvGV(outside) ? - generic_pv_escape( - newSVpvs_flags("", SVs_TEMP), - GvNAME(CvGV(outside)), - GvNAMELEN(CvGV(outside)), - GvNAMEUTF8(CvGV(outside))) - : "UNDEFINED")); - } - if (CvOUTSIDE(sv) - && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))) - do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim); - break; + Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv)); + if (!CvISXSUB(sv)) { + Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv))); + if (nest < maxnest) { + do_dump_pad(level+1, file, CvPADLIST(sv), 0); + } + } + else + Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv)); + { + const CV * const outside = CvOUTSIDE(sv); + Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n", + PTR2UV(outside), + (!outside ? "null" + : CvANON(outside) ? "ANON" + : (outside == PL_main_cv) ? "MAIN" + : CvUNIQUE(outside) ? "UNIQUE" + : CvGV(outside) ? + generic_pv_escape( + newSVpvs_flags("", SVs_TEMP), + GvNAME(CvGV(outside)), + GvNAMELEN(CvGV(outside)), + GvNAMEUTF8(CvGV(outside))) + : "UNDEFINED")); + } + if (CvOUTSIDE(sv) + && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))) + do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim); + break; case SVt_PVGV: case SVt_PVLV: - if (type == SVt_PVLV) { - Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv)); - Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv)); - Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv)); - Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv))); - Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv)); - if (isALPHA_FOLD_NE(LvTYPE(sv), 't')) - do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest, - dumpops, pvlim); - } - if (isREGEXP(sv)) goto dumpregexp; - if (!isGV_with_GP(sv)) - break; + if (type == SVt_PVLV) { + Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv)); + Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv)); + Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv)); + Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv))); + Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv)); + if (isALPHA_FOLD_NE(LvTYPE(sv), 't')) + do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest, + dumpops, pvlim); + } + if (isREGEXP(sv)) goto dumpregexp; + if (!isGV_with_GP(sv)) + break; { SV* tmpsv = newSVpvs_flags("", SVs_TEMP); Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", @@ -2347,78 +2347,78 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo GvNAMELEN(sv), GvNAMEUTF8(sv))); } - Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv)); - do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); - Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv)); - Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv))); - if (!GvGP(sv)) - break; - Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv))); - Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv)); - Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv))); - Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv))); - Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv))); - Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv))); - Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv))); - Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv)); - Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf - " (%s)\n", - (UV)GvGPFLAGS(sv), - ""); - Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv)); - Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); - do_gv_dump (level, file, " EGV", GvEGV(sv)); - break; + Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv)); + do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); + Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv)); + Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv))); + if (!GvGP(sv)) + break; + Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv))); + Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv)); + Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv))); + Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv))); + Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv))); + Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv))); + Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv))); + Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv)); + Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf + " (%s)\n", + (UV)GvGPFLAGS(sv), + ""); + Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv)); + Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); + do_gv_dump (level, file, " EGV", GvEGV(sv)); + break; case SVt_PVIO: - Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv))); - Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv))); - Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv))); - Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv)); - Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv)); - Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv)); - Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv)); + Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv))); + Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv))); + Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv))); + Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv)); + Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv)); + Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv)); + Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv)); if (IoTOP_NAME(sv)) Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); - if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV) - do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); - else { - Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n", - PTR2UV(IoTOP_GV(sv))); - do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1, - maxnest, dumpops, pvlim); - } - /* Source filters hide things that are not GVs in these three, so let's - be careful out there. */ + if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV) + do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); + else { + Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n", + PTR2UV(IoTOP_GV(sv))); + do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1, + maxnest, dumpops, pvlim); + } + /* Source filters hide things that are not GVs in these three, so let's + be careful out there. */ if (IoFMT_NAME(sv)) Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); - if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV) - do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); - else { - Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n", - PTR2UV(IoFMT_GV(sv))); - do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1, - maxnest, dumpops, pvlim); - } + if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV) + do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); + else { + Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n", + PTR2UV(IoFMT_GV(sv))); + do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1, + maxnest, dumpops, pvlim); + } if (IoBOTTOM_NAME(sv)) Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); - if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV) - do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); - else { - Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n", - PTR2UV(IoBOTTOM_GV(sv))); - do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1, - maxnest, dumpops, pvlim); - } - if (isPRINT(IoTYPE(sv))) + if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV) + do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); + else { + Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n", + PTR2UV(IoBOTTOM_GV(sv))); + do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1, + maxnest, dumpops, pvlim); + } + if (isPRINT(IoTYPE(sv))) Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv)); - else + else Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv)); - Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv)); - break; + Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv)); + break; case SVt_REGEXP: dumpregexp: - { - struct regexp * const r = ReANY((REGEXP*)sv); + { + struct regexp * const r = ReANY((REGEXP*)sv); #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \ sv_setpv(d,""); \ @@ -2433,7 +2433,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo (UV)(r->compflags), SvPVX_const(d)); SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names); - Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n", + Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n", (UV)(r->extflags), SvPVX_const(d)); Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n", @@ -2444,56 +2444,56 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo (UV)(r->intflags), SvPVX_const(d)); } else { Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n", - (UV)(r->intflags)); + (UV)(r->intflags)); } #undef SV_SET_STRINGIFY_REGEXP_FLAGS - Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n", - (UV)(r->nparens)); - Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n", - (UV)(r->lastparen)); - Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n", - (UV)(r->lastcloseparen)); - Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n", - (IV)(r->minlen)); - Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n", - (IV)(r->minlenret)); - Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n", - (UV)(r->gofs)); - Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n", - (UV)(r->pre_prefix)); - Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n", - (IV)(r->sublen)); - Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n", - (IV)(r->suboffset)); - Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n", - (IV)(r->subcoffset)); - if (r->subbeg) - Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n", - PTR2UV(r->subbeg), - pv_display(d, r->subbeg, r->sublen, 50, pvlim)); - else - Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n"); - Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n", - PTR2UV(r->mother_re)); - if (nest < maxnest && r->mother_re) - do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1, - maxnest, dumpops, pvlim); - Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n", - PTR2UV(r->paren_names)); - Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n", - PTR2UV(r->substrs)); - Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n", - PTR2UV(r->pprivate)); - Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n", - PTR2UV(r->offs)); - Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n", - PTR2UV(r->qr_anoncv)); + Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n", + (UV)(r->nparens)); + Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n", + (UV)(r->lastparen)); + Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n", + (UV)(r->lastcloseparen)); + Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n", + (IV)(r->minlen)); + Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n", + (IV)(r->minlenret)); + Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n", + (UV)(r->gofs)); + Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n", + (UV)(r->pre_prefix)); + Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n", + (IV)(r->sublen)); + Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n", + (IV)(r->suboffset)); + Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n", + (IV)(r->subcoffset)); + if (r->subbeg) + Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n", + PTR2UV(r->subbeg), + pv_display(d, r->subbeg, r->sublen, 50, pvlim)); + else + Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n"); + Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n", + PTR2UV(r->mother_re)); + if (nest < maxnest && r->mother_re) + do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1, + maxnest, dumpops, pvlim); + Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n", + PTR2UV(r->paren_names)); + Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n", + PTR2UV(r->substrs)); + Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n", + PTR2UV(r->pprivate)); + Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n", + PTR2UV(r->offs)); + Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n", + PTR2UV(r->qr_anoncv)); #ifdef PERL_ANY_COW - Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n", - PTR2UV(r->saved_copy)); + Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n", + PTR2UV(r->saved_copy)); #endif - } - break; + } + break; } SvREFCNT_dec_NN(d); } @@ -2512,9 +2512,9 @@ void Perl_sv_dump(pTHX_ SV *sv) { if (sv && SvROK(sv)) - do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0); + do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0); else - do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); + do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); } int @@ -2527,8 +2527,8 @@ Perl_runops_debug(pTHX) #endif if (!PL_op) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); - return 0; + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); + return 0; } DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n")); do { @@ -2544,29 +2544,29 @@ Perl_runops_debug(pTHX) PL_stack_base + PL_curstackinfo->si_stack_hwm); PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base; #endif - if (PL_debug) { + if (PL_debug) { ENTER; SAVETMPS; - if (PL_watchaddr && (*PL_watchaddr != PL_watchok)) - PerlIO_printf(Perl_debug_log, - "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n", - PTR2UV(PL_watchaddr), PTR2UV(PL_watchok), - PTR2UV(*PL_watchaddr)); - if (DEBUG_s_TEST_) { - if (DEBUG_v_TEST_) { - PerlIO_printf(Perl_debug_log, "\n"); - deb_stack_all(); - } - else - debstack(); - } - - - if (DEBUG_t_TEST_) debop(PL_op); - if (DEBUG_P_TEST_) debprof(PL_op); + if (PL_watchaddr && (*PL_watchaddr != PL_watchok)) + PerlIO_printf(Perl_debug_log, + "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n", + PTR2UV(PL_watchaddr), PTR2UV(PL_watchok), + PTR2UV(*PL_watchaddr)); + if (DEBUG_s_TEST_) { + if (DEBUG_v_TEST_) { + PerlIO_printf(Perl_debug_log, "\n"); + deb_stack_all(); + } + else + debstack(); + } + + + if (DEBUG_t_TEST_) debop(PL_op); + if (DEBUG_P_TEST_) debprof(PL_op); FREETMPS; LEAVE; - } + } PERL_DTRACE_PROBE_OP(PL_op); } while ((PL_op = PL_op->op_ppaddr(aTHX))); @@ -2861,26 +2861,26 @@ Perl_debop(pTHX_ const OP *o) PERL_ARGS_ASSERT_DEBOP; if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) - return 0; + return 0; Perl_deb(aTHX_ "%s", OP_NAME(o)); switch (o->op_type) { case OP_CONST: case OP_HINTSEVAL: - /* With ITHREADS, consts are stored in the pad, and the right pad - * may not be active here, so check. - * Looks like only during compiling the pads are illegal. - */ + /* With ITHREADS, consts are stored in the pad, and the right pad + * may not be active here, so check. + * Looks like only during compiling the pads are illegal. + */ #ifdef USE_ITHREADS - if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME) + if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME) #endif - PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); - break; + PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); + break; case OP_GVSV: case OP_GV: PerlIO_printf(Perl_debug_log, "(%" SVf ")", SVfARG(S_gv_display(aTHX_ cGVOPo_gv))); - break; + break; case OP_PADSV: case OP_PADAV: @@ -2905,7 +2905,7 @@ Perl_debop(pTHX_ const OP *o) break; default: - break; + break; } PerlIO_printf(Perl_debug_log, "\n"); return 0; @@ -2928,29 +2928,29 @@ Perl_op_class(pTHX_ const OP *o) bool custom = 0; if (!o) - return OPclass_NULL; + return OPclass_NULL; if (o->op_type == 0) { - if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) - return OPclass_COP; - return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; + if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) + return OPclass_COP; + return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; } if (o->op_type == OP_SASSIGN) - return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP); + return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP); if (o->op_type == OP_AELEMFAST) { #ifdef USE_ITHREADS - return OPclass_PADOP; + return OPclass_PADOP; #else - return OPclass_SVOP; + return OPclass_SVOP; #endif } #ifdef USE_ITHREADS if (o->op_type == OP_GV || o->op_type == OP_GVSV || - o->op_type == OP_RCATLINE) - return OPclass_PADOP; + o->op_type == OP_RCATLINE) + return OPclass_PADOP; #endif if (o->op_type == OP_CUSTOM) @@ -2958,28 +2958,28 @@ Perl_op_class(pTHX_ const OP *o) switch (OP_CLASS(o)) { case OA_BASEOP: - return OPclass_BASEOP; + return OPclass_BASEOP; case OA_UNOP: - return OPclass_UNOP; + return OPclass_UNOP; case OA_BINOP: - return OPclass_BINOP; + return OPclass_BINOP; case OA_LOGOP: - return OPclass_LOGOP; + return OPclass_LOGOP; case OA_LISTOP: - return OPclass_LISTOP; + return OPclass_LISTOP; case OA_PMOP: - return OPclass_PMOP; + return OPclass_PMOP; case OA_SVOP: - return OPclass_SVOP; + return OPclass_SVOP; case OA_PADOP: - return OPclass_PADOP; + return OPclass_PADOP; case OA_PVOP_OR_SVOP: /* @@ -2989,70 +2989,70 @@ Perl_op_class(pTHX_ const OP *o) * the OP is an SVOP (or, under threads, a PADOP), * and the SV is an AV. */ - return (!custom && - (o->op_private & OPpTRANS_USE_SVOP) - ) + return (!custom && + (o->op_private & OPpTRANS_USE_SVOP) + ) #if defined(USE_ITHREADS) - ? OPclass_PADOP : OPclass_PVOP; + ? OPclass_PADOP : OPclass_PVOP; #else - ? OPclass_SVOP : OPclass_PVOP; + ? OPclass_SVOP : OPclass_PVOP; #endif case OA_LOOP: - return OPclass_LOOP; + return OPclass_LOOP; case OA_COP: - return OPclass_COP; + return OPclass_COP; case OA_BASEOP_OR_UNOP: - /* - * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on - * whether parens were seen. perly.y uses OPf_SPECIAL to - * signal whether a BASEOP had empty parens or none. - * Some other UNOPs are created later, though, so the best - * test is OPf_KIDS, which is set in newUNOP. - */ - return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; + /* + * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on + * whether parens were seen. perly.y uses OPf_SPECIAL to + * signal whether a BASEOP had empty parens or none. + * Some other UNOPs are created later, though, so the best + * test is OPf_KIDS, which is set in newUNOP. + */ + return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; case OA_FILESTATOP: - /* - * The file stat OPs are created via UNI(OP_foo) in toke.c but use - * the OPf_REF flag to distinguish between OP types instead of the - * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we - * return OPclass_UNOP so that walkoptree can find our children. If - * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set - * (no argument to the operator) it's an OP; with OPf_REF set it's - * an SVOP (and op_sv is the GV for the filehandle argument). - */ - return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP : + /* + * The file stat OPs are created via UNI(OP_foo) in toke.c but use + * the OPf_REF flag to distinguish between OP types instead of the + * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we + * return OPclass_UNOP so that walkoptree can find our children. If + * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set + * (no argument to the operator) it's an OP; with OPf_REF set it's + * an SVOP (and op_sv is the GV for the filehandle argument). + */ + return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP : #ifdef USE_ITHREADS - (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP); + (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP); #else - (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP); + (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP); #endif case OA_LOOPEXOP: - /* - * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a - * label was omitted (in which case it's a BASEOP) or else a term was - * seen. In this last case, all except goto are definitely PVOP but - * goto is either a PVOP (with an ordinary constant label), an UNOP - * with OPf_STACKED (with a non-constant non-sub) or an UNOP for - * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to - * get set. - */ - if (o->op_flags & OPf_STACKED) - return OPclass_UNOP; - else if (o->op_flags & OPf_SPECIAL) - return OPclass_BASEOP; - else - return OPclass_PVOP; + /* + * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a + * label was omitted (in which case it's a BASEOP) or else a term was + * seen. In this last case, all except goto are definitely PVOP but + * goto is either a PVOP (with an ordinary constant label), an UNOP + * with OPf_STACKED (with a non-constant non-sub) or an UNOP for + * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to + * get set. + */ + if (o->op_flags & OPf_STACKED) + return OPclass_UNOP; + else if (o->op_flags & OPf_SPECIAL) + return OPclass_BASEOP; + else + return OPclass_PVOP; case OA_METHOP: - return OPclass_METHOP; + return OPclass_METHOP; case OA_UNOP_AUX: - return OPclass_UNOP_AUX; + return OPclass_UNOP_AUX; } Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n", - OP_NAME(o)); + OP_NAME(o)); return OPclass_BASEOP; } @@ -3090,7 +3090,7 @@ Perl_watch(pTHX_ char **addr) PL_watchaddr = addr; PL_watchok = *addr; PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n", - PTR2UV(PL_watchaddr), PTR2UV(PL_watchok)); + PTR2UV(PL_watchaddr), PTR2UV(PL_watchok)); } STATIC void @@ -3099,9 +3099,9 @@ S_debprof(pTHX_ const OP *o) PERL_ARGS_ASSERT_DEBPROF; if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash)) - return; + return; if (!PL_profiledata) - Newxz(PL_profiledata, MAXO, U32); + Newxz(PL_profiledata, MAXO, U32); ++PL_profiledata[o->op_type]; } @@ -3110,11 +3110,11 @@ Perl_debprofdump(pTHX) { unsigned i; if (!PL_profiledata) - return; + return; for (i = 0; i < MAXO; i++) { - if (PL_profiledata[i]) - PerlIO_printf(Perl_debug_log, - "%5lu %s\n", (unsigned long)PL_profiledata[i], + if (PL_profiledata[i]) + PerlIO_printf(Perl_debug_log, + "%5lu %s\n", (unsigned long)PL_profiledata[i], PL_op_name[i]); } } diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 1a27fbdd20..a818e7ac5c 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -27,10 +27,10 @@ typedef struct { SV* x_dl_last_error; /* pointer to allocated memory for - last error message */ + last error message */ #if defined(PERL_IN_DL_HPUX_XS) || defined(PERL_IN_DL_DLOPEN_XS) int x_dl_nonlazy; /* flag for immediate rather than lazy - linking (spots unresolved symbol) */ + linking (spots unresolved symbol) */ #endif #ifdef DL_LOADONCEONLY HV * x_dl_loaded_files; /* only needed on a few systems */ @@ -62,8 +62,8 @@ START_MY_CXT #ifdef DEBUGGING #define DLDEBUG(level,code) \ STMT_START { \ - dMY_CXT; \ - if (dl_debug>=level) { code; } \ + dMY_CXT; \ + if (dl_debug>=level) { code; } \ } STMT_END #else #define DLDEBUG(level,code) NOOP @@ -109,25 +109,25 @@ dl_generic_private_init(pTHX) /* called by dl_*.xs dl_private_init() */ #endif #ifdef DEBUGGING { - SV *sv = get_sv("DynaLoader::dl_debug", 0); - dl_debug = sv ? SvIV(sv) : 0; + SV *sv = get_sv("DynaLoader::dl_debug", 0); + dl_debug = sv ? SvIV(sv) : 0; } #endif #if defined(PERL_IN_DL_HPUX_XS) || defined(PERL_IN_DL_DLOPEN_XS) if ( (perl_dl_nonlazy = PerlEnv_getenv("PERL_DL_NONLAZY")) != NULL - && grok_atoUV(perl_dl_nonlazy, &uv, NULL) - && uv <= INT_MAX + && grok_atoUV(perl_dl_nonlazy, &uv, NULL) + && uv <= INT_MAX ) { - dl_nonlazy = (int)uv; + dl_nonlazy = (int)uv; } else - dl_nonlazy = 0; + dl_nonlazy = 0; if (dl_nonlazy) - DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n")); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n")); #endif #ifdef DL_LOADONCEONLY if (!dl_loaded_files) - dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ + dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ #endif #ifdef DL_UNLOAD_ALL_AT_EXIT call_atexit(&dl_unload_all_files, (void*)0); @@ -155,10 +155,10 @@ SaveError(pTHX_ const char* pat, ...) len++; /* include terminating null char */ { - dMY_CXT; + dMY_CXT; /* Copy message into dl_last_error (including terminating null char) */ - sv_setpvn(MY_CXT.x_dl_last_error, message, len) ; - DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",dl_last_error)); + sv_setpvn(MY_CXT.x_dl_last_error, message, len) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",dl_last_error)); } } #endif diff --git a/ext/File-Glob/bsd_glob.c b/ext/File-Glob/bsd_glob.c index b038dd117a..7a810db93f 100644 --- a/ext/File-Glob/bsd_glob.c +++ b/ext/File-Glob/bsd_glob.c @@ -74,8 +74,8 @@ static char sscsid[]= "$OpenBSD: glob.c,v 1.8.10.1 2001/04/10 jason Exp $"; # include <pwd.h> #else #if defined(HAS_PASSWD) && !defined(VMS) - struct passwd *getpwnam(char *); - struct passwd *getpwuid(Uid_t); + struct passwd *getpwnam(char *); + struct passwd *getpwuid(Uid_t); #endif #endif @@ -168,12 +168,12 @@ static int g_stat(Char *, Stat_t *, glob_t *); static int glob0(const Char *, glob_t *); static int glob1(Char *, Char *, glob_t *, size_t *); static int glob2(Char *, Char *, Char *, Char *, Char *, Char *, - glob_t *, size_t *); + glob_t *, size_t *); static int glob3(Char *, Char *, Char *, Char *, Char *, - Char *, Char *, glob_t *, size_t *); + Char *, Char *, glob_t *, size_t *); static int globextend(const Char *, glob_t *, size_t *); static const Char * - globtilde(const Char *, Char *, size_t, glob_t *); + globtilde(const Char *, Char *, size_t, glob_t *); static int globexp1(const Char *, glob_t *); static int globexp2(const Char *, const Char *, glob_t *, int *); static int match(Char *, Char *, Char *, int); @@ -216,82 +216,82 @@ my_readdir(DIR *d) int bsd_glob(const char *pattern, int flags, - int (*errfunc)(const char *, int), glob_t *pglob) + int (*errfunc)(const char *, int), glob_t *pglob) { - const U8 *patnext; - int c; - Char *bufnext, *bufend, patbuf[MAXPATHLEN]; - patnext = (U8 *) pattern; - /* TODO: GLOB_APPEND / GLOB_DOOFFS aren't supported yet */ + const U8 *patnext; + int c; + Char *bufnext, *bufend, patbuf[MAXPATHLEN]; + patnext = (U8 *) pattern; + /* TODO: GLOB_APPEND / GLOB_DOOFFS aren't supported yet */ #if 0 - if (!(flags & GLOB_APPEND)) { - pglob->gl_pathc = 0; - pglob->gl_pathv = NULL; - if (!(flags & GLOB_DOOFFS)) - pglob->gl_offs = 0; - } + if (!(flags & GLOB_APPEND)) { + pglob->gl_pathc = 0; + pglob->gl_pathv = NULL; + if (!(flags & GLOB_DOOFFS)) + pglob->gl_offs = 0; + } #else - pglob->gl_pathc = 0; - pglob->gl_pathv = NULL; - pglob->gl_offs = 0; + pglob->gl_pathc = 0; + pglob->gl_pathv = NULL; + pglob->gl_offs = 0; #endif - pglob->gl_flags = flags & ~GLOB_MAGCHAR; - pglob->gl_errfunc = errfunc; - pglob->gl_matchc = 0; + pglob->gl_flags = flags & ~GLOB_MAGCHAR; + pglob->gl_errfunc = errfunc; + pglob->gl_matchc = 0; - bufnext = patbuf; - bufend = bufnext + MAXPATHLEN - 1; + bufnext = patbuf; + bufend = bufnext + MAXPATHLEN - 1; #ifdef DOSISH - /* Nasty hack to treat patterns like "C:*" correctly. In this - * case, the * should match any file in the current directory - * on the C: drive. However, the glob code does not treat the - * colon specially, so it looks for files beginning "C:" in - * the current directory. To fix this, change the pattern to - * add an explicit "./" at the start (just after the drive - * letter and colon - ie change to "C:./"). - */ - if (isalpha(pattern[0]) && pattern[1] == ':' && - pattern[2] != BG_SEP && pattern[2] != BG_SEP2 && - bufend - bufnext > 4) { - *bufnext++ = pattern[0]; - *bufnext++ = ':'; - *bufnext++ = '.'; - *bufnext++ = BG_SEP; - patnext += 2; - } + /* Nasty hack to treat patterns like "C:*" correctly. In this + * case, the * should match any file in the current directory + * on the C: drive. However, the glob code does not treat the + * colon specially, so it looks for files beginning "C:" in + * the current directory. To fix this, change the pattern to + * add an explicit "./" at the start (just after the drive + * letter and colon - ie change to "C:./"). + */ + if (isalpha(pattern[0]) && pattern[1] == ':' && + pattern[2] != BG_SEP && pattern[2] != BG_SEP2 && + bufend - bufnext > 4) { + *bufnext++ = pattern[0]; + *bufnext++ = ':'; + *bufnext++ = '.'; + *bufnext++ = BG_SEP; + patnext += 2; + } #endif - if (flags & GLOB_QUOTE) { - /* Protect the quoted characters. */ - while (bufnext < bufend && (c = *patnext++) != BG_EOS) - if (c == BG_QUOTE) { + if (flags & GLOB_QUOTE) { + /* Protect the quoted characters. */ + while (bufnext < bufend && (c = *patnext++) != BG_EOS) + if (c == BG_QUOTE) { #ifdef DOSISH - /* To avoid backslashitis on Win32, - * we only treat \ as a quoting character - * if it precedes one of the - * metacharacters []-{}~\ - */ - if ((c = *patnext++) != '[' && c != ']' && - c != '-' && c != '{' && c != '}' && - c != '~' && c != '\\') { + /* To avoid backslashitis on Win32, + * we only treat \ as a quoting character + * if it precedes one of the + * metacharacters []-{}~\ + */ + if ((c = *patnext++) != '[' && c != ']' && + c != '-' && c != '{' && c != '}' && + c != '~' && c != '\\') { #else - if ((c = *patnext++) == BG_EOS) { + if ((c = *patnext++) == BG_EOS) { #endif - c = BG_QUOTE; - --patnext; - } - *bufnext++ = c | M_PROTECT; - } else - *bufnext++ = c; - } else - while (bufnext < bufend && (c = *patnext++) != BG_EOS) - *bufnext++ = c; - *bufnext = BG_EOS; - - if (flags & GLOB_BRACE) - return globexp1(patbuf, pglob); - else - return glob0(patbuf, pglob); + c = BG_QUOTE; + --patnext; + } + *bufnext++ = c | M_PROTECT; + } else + *bufnext++ = c; + } else + while (bufnext < bufend && (c = *patnext++) != BG_EOS) + *bufnext++ = c; + *bufnext = BG_EOS; + + if (flags & GLOB_BRACE) + return globexp1(patbuf, pglob); + else + return glob0(patbuf, pglob); } /* @@ -302,18 +302,18 @@ bsd_glob(const char *pattern, int flags, static int globexp1(const Char *pattern, glob_t *pglob) { - const Char* ptr = pattern; - int rv; + const Char* ptr = pattern; + int rv; - /* Protect a single {}, for find(1), like csh */ - if (pattern[0] == BG_LBRACE && pattern[1] == BG_RBRACE && pattern[2] == BG_EOS) - return glob0(pattern, pglob); + /* Protect a single {}, for find(1), like csh */ + if (pattern[0] == BG_LBRACE && pattern[1] == BG_RBRACE && pattern[2] == BG_EOS) + return glob0(pattern, pglob); - while ((ptr = (const Char *) g_strchr((Char *) ptr, BG_LBRACE)) != NULL) - if (!globexp2(ptr, pattern, pglob, &rv)) - return rv; + while ((ptr = (const Char *) g_strchr((Char *) ptr, BG_LBRACE)) != NULL) + if (!globexp2(ptr, pattern, pglob, &rv)) + return rv; - return glob0(pattern, pglob); + return glob0(pattern, pglob); } @@ -324,103 +324,103 @@ globexp1(const Char *pattern, glob_t *pglob) */ static int globexp2(const Char *ptr, const Char *pattern, - glob_t *pglob, int *rv) + glob_t *pglob, int *rv) { - int i; - Char *lm, *ls; - const Char *pe, *pm, *pm1, *pl; - Char patbuf[MAXPATHLEN]; - - /* copy part up to the brace */ - for (lm = patbuf, pm = pattern; pm != ptr; *lm++ = *pm++) - ; - *lm = BG_EOS; - ls = lm; - - /* Find the balanced brace */ - for (i = 0, pe = ++ptr; *pe; pe++) - if (*pe == BG_LBRACKET) { - /* Ignore everything between [] */ - for (pm = pe++; *pe != BG_RBRACKET && *pe != BG_EOS; pe++) - ; - if (*pe == BG_EOS) { - /* - * We could not find a matching BG_RBRACKET. - * Ignore and just look for BG_RBRACE - */ - pe = pm; - } - } else if (*pe == BG_LBRACE) - i++; - else if (*pe == BG_RBRACE) { - if (i == 0) - break; - i--; - } - - /* Non matching braces; just glob the pattern */ - if (i != 0 || *pe == BG_EOS) { - *rv = glob0(patbuf, pglob); - return 0; - } - - for (i = 0, pl = pm = ptr; pm <= pe; pm++) { - switch (*pm) { - case BG_LBRACKET: - /* Ignore everything between [] */ - for (pm1 = pm++; *pm != BG_RBRACKET && *pm != BG_EOS; pm++) - ; - if (*pm == BG_EOS) { - /* - * We could not find a matching BG_RBRACKET. - * Ignore and just look for BG_RBRACE - */ - pm = pm1; - } - break; - - case BG_LBRACE: - i++; - break; - - case BG_RBRACE: - if (i) { - i--; - break; - } - /* FALLTHROUGH */ - case BG_COMMA: - if (i && *pm == BG_COMMA) - break; - else { - /* Append the current string */ - for (lm = ls; (pl < pm); *lm++ = *pl++) - ; - - /* - * Append the rest of the pattern after the - * closing brace - */ - for (pl = pe + 1; (*lm++ = *pl++) != BG_EOS; ) - ; - - /* Expand the current pattern */ + int i; + Char *lm, *ls; + const Char *pe, *pm, *pm1, *pl; + Char patbuf[MAXPATHLEN]; + + /* copy part up to the brace */ + for (lm = patbuf, pm = pattern; pm != ptr; *lm++ = *pm++) + ; + *lm = BG_EOS; + ls = lm; + + /* Find the balanced brace */ + for (i = 0, pe = ++ptr; *pe; pe++) + if (*pe == BG_LBRACKET) { + /* Ignore everything between [] */ + for (pm = pe++; *pe != BG_RBRACKET && *pe != BG_EOS; pe++) + ; + if (*pe == BG_EOS) { + /* + * We could not find a matching BG_RBRACKET. + * Ignore and just look for BG_RBRACE + */ + pe = pm; + } + } else if (*pe == BG_LBRACE) + i++; + else if (*pe == BG_RBRACE) { + if (i == 0) + break; + i--; + } + + /* Non matching braces; just glob the pattern */ + if (i != 0 || *pe == BG_EOS) { + *rv = glob0(patbuf, pglob); + return 0; + } + + for (i = 0, pl = pm = ptr; pm <= pe; pm++) { + switch (*pm) { + case BG_LBRACKET: + /* Ignore everything between [] */ + for (pm1 = pm++; *pm != BG_RBRACKET && *pm != BG_EOS; pm++) + ; + if (*pm == BG_EOS) { + /* + * We could not find a matching BG_RBRACKET. + * Ignore and just look for BG_RBRACE + */ + pm = pm1; + } + break; + + case BG_LBRACE: + i++; + break; + + case BG_RBRACE: + if (i) { + i--; + break; + } + /* FALLTHROUGH */ + case BG_COMMA: + if (i && *pm == BG_COMMA) + break; + else { + /* Append the current string */ + for (lm = ls; (pl < pm); *lm++ = *pl++) + ; + + /* + * Append the rest of the pattern after the + * closing brace + */ + for (pl = pe + 1; (*lm++ = *pl++) != BG_EOS; ) + ; + + /* Expand the current pattern */ #ifdef GLOB_DEBUG - qprintf("globexp2:", patbuf); + qprintf("globexp2:", patbuf); #endif /* GLOB_DEBUG */ - *rv = globexp1(patbuf, pglob); - - /* move after the comma, to the next string */ - pl = pm + 1; - } - break; - - default: - break; - } - } - *rv = 0; - return 0; + *rv = globexp1(patbuf, pglob); + + /* move after the comma, to the next string */ + pl = pm + 1; + } + break; + + default: + break; + } + } + *rv = 0; + return 0; } @@ -431,76 +431,76 @@ globexp2(const Char *ptr, const Char *pattern, static const Char * globtilde(const Char *pattern, Char *patbuf, size_t patbuf_len, glob_t *pglob) { - char *h; - const Char *p; - Char *b, *eb; + char *h; + const Char *p; + Char *b, *eb; - if (*pattern != BG_TILDE || !(pglob->gl_flags & GLOB_TILDE)) - return pattern; + if (*pattern != BG_TILDE || !(pglob->gl_flags & GLOB_TILDE)) + return pattern; - /* Copy up to the end of the string or / */ - eb = &patbuf[patbuf_len - 1]; - for (p = pattern + 1, h = (char *) patbuf; - h < (char*)eb && *p && *p != BG_SLASH; *h++ = (char)*p++) - ; + /* Copy up to the end of the string or / */ + eb = &patbuf[patbuf_len - 1]; + for (p = pattern + 1, h = (char *) patbuf; + h < (char*)eb && *p && *p != BG_SLASH; *h++ = (char)*p++) + ; - *h = BG_EOS; + *h = BG_EOS; #if 0 - if (h == (char *)eb) - return what; + if (h == (char *)eb) + return what; #endif - if (((char *) patbuf)[0] == BG_EOS) { - /* - * handle a plain ~ or ~/ by expanding $HOME - * first and then trying the password file - * or $USERPROFILE on DOSISH systems - */ - if ((h = PerlEnv_getenv("HOME")) == NULL) { + if (((char *) patbuf)[0] == BG_EOS) { + /* + * handle a plain ~ or ~/ by expanding $HOME + * first and then trying the password file + * or $USERPROFILE on DOSISH systems + */ + if ((h = PerlEnv_getenv("HOME")) == NULL) { #ifdef HAS_PASSWD - struct passwd *pwd; - if ((pwd = getpwuid(getuid())) == NULL) - return pattern; - else - h = pwd->pw_dir; + struct passwd *pwd; + if ((pwd = getpwuid(getuid())) == NULL) + return pattern; + else + h = pwd->pw_dir; #elif DOSISH - /* - * When no passwd file, fallback to the USERPROFILE - * environment variable on DOSish systems. - */ - if ((h = PerlEnv_getenv("USERPROFILE")) == NULL) { - return pattern; - } + /* + * When no passwd file, fallback to the USERPROFILE + * environment variable on DOSish systems. + */ + if ((h = PerlEnv_getenv("USERPROFILE")) == NULL) { + return pattern; + } #else return pattern; #endif - } - } else { - /* - * Expand a ~user - */ + } + } else { + /* + * Expand a ~user + */ #ifdef HAS_PASSWD - struct passwd *pwd; - if ((pwd = getpwnam((char*) patbuf)) == NULL) - return pattern; - else - h = pwd->pw_dir; + struct passwd *pwd; + if ((pwd = getpwnam((char*) patbuf)) == NULL) + return pattern; + else + h = pwd->pw_dir; #else return pattern; #endif - } + } - /* Copy the home directory */ - for (b = patbuf; b < eb && *h; *b++ = *h++) - ; + /* Copy the home directory */ + for (b = patbuf; b < eb && *h; *b++ = *h++) + ; - /* Append the rest of the pattern */ - while (b < eb && (*b++ = *p++) != BG_EOS) - ; - *b = BG_EOS; + /* Append the rest of the pattern */ + while (b < eb && (*b++ = *p++) != BG_EOS) + ; + *b = BG_EOS; - return patbuf; + return patbuf; } @@ -514,142 +514,142 @@ globtilde(const Char *pattern, Char *patbuf, size_t patbuf_len, glob_t *pglob) static int glob0(const Char *pattern, glob_t *pglob) { - const Char *qpat, *qpatnext; - int c, err, oldflags, oldpathc; - Char *bufnext, patbuf[MAXPATHLEN]; - size_t limit = 0; - - qpat = globtilde(pattern, patbuf, MAXPATHLEN, pglob); - qpatnext = qpat; - oldflags = pglob->gl_flags; - oldpathc = pglob->gl_pathc; - bufnext = patbuf; - - /* We don't need to check for buffer overflow any more. */ - while ((c = *qpatnext++) != BG_EOS) { - switch (c) { - case BG_LBRACKET: - c = *qpatnext; - if (c == BG_NOT) - ++qpatnext; - if (*qpatnext == BG_EOS || - g_strchr((Char *) qpatnext+1, BG_RBRACKET) == NULL) { - *bufnext++ = BG_LBRACKET; - if (c == BG_NOT) - --qpatnext; - break; - } - *bufnext++ = M_SET; - if (c == BG_NOT) - *bufnext++ = M_NOT; - c = *qpatnext++; - do { - *bufnext++ = CHAR(c); - if (*qpatnext == BG_RANGE && - (c = qpatnext[1]) != BG_RBRACKET) { - *bufnext++ = M_RNG; - *bufnext++ = CHAR(c); - qpatnext += 2; - } - } while ((c = *qpatnext++) != BG_RBRACKET); - pglob->gl_flags |= GLOB_MAGCHAR; - *bufnext++ = M_END; - break; - case BG_QUESTION: - pglob->gl_flags |= GLOB_MAGCHAR; - *bufnext++ = M_ONE; - break; - case BG_STAR: - pglob->gl_flags |= GLOB_MAGCHAR; + const Char *qpat, *qpatnext; + int c, err, oldflags, oldpathc; + Char *bufnext, patbuf[MAXPATHLEN]; + size_t limit = 0; + + qpat = globtilde(pattern, patbuf, MAXPATHLEN, pglob); + qpatnext = qpat; + oldflags = pglob->gl_flags; + oldpathc = pglob->gl_pathc; + bufnext = patbuf; + + /* We don't need to check for buffer overflow any more. */ + while ((c = *qpatnext++) != BG_EOS) { + switch (c) { + case BG_LBRACKET: + c = *qpatnext; + if (c == BG_NOT) + ++qpatnext; + if (*qpatnext == BG_EOS || + g_strchr((Char *) qpatnext+1, BG_RBRACKET) == NULL) { + *bufnext++ = BG_LBRACKET; + if (c == BG_NOT) + --qpatnext; + break; + } + *bufnext++ = M_SET; + if (c == BG_NOT) + *bufnext++ = M_NOT; + c = *qpatnext++; + do { + *bufnext++ = CHAR(c); + if (*qpatnext == BG_RANGE && + (c = qpatnext[1]) != BG_RBRACKET) { + *bufnext++ = M_RNG; + *bufnext++ = CHAR(c); + qpatnext += 2; + } + } while ((c = *qpatnext++) != BG_RBRACKET); + pglob->gl_flags |= GLOB_MAGCHAR; + *bufnext++ = M_END; + break; + case BG_QUESTION: + pglob->gl_flags |= GLOB_MAGCHAR; + *bufnext++ = M_ONE; + break; + case BG_STAR: + pglob->gl_flags |= GLOB_MAGCHAR; /* Collapse adjacent stars to one. * This is required to ensure that a pattern like * "a**" matches a name like "a", as without this * check when the first star matched everything it would * cause the second star to return a match fail. * As long ** is folded here this does not happen. - */ - if (bufnext == patbuf || bufnext[-1] != M_ALL) - *bufnext++ = M_ALL; - break; - default: - *bufnext++ = CHAR(c); - break; - } - } - *bufnext = BG_EOS; + */ + if (bufnext == patbuf || bufnext[-1] != M_ALL) + *bufnext++ = M_ALL; + break; + default: + *bufnext++ = CHAR(c); + break; + } + } + *bufnext = BG_EOS; #ifdef GLOB_DEBUG - qprintf("glob0:", patbuf); + qprintf("glob0:", patbuf); #endif /* GLOB_DEBUG */ - if ((err = glob1(patbuf, patbuf+MAXPATHLEN-1, pglob, &limit)) != 0) { - pglob->gl_flags = oldflags; - return(err); - } - - /* - * If there was no match we are going to append the pattern - * if GLOB_NOCHECK was specified or if GLOB_NOMAGIC was specified - * and the pattern did not contain any magic characters - * GLOB_NOMAGIC is there just for compatibility with csh. - */ - if (pglob->gl_pathc == oldpathc && - ((pglob->gl_flags & GLOB_NOCHECK) || - ((pglob->gl_flags & GLOB_NOMAGIC) && - !(pglob->gl_flags & GLOB_MAGCHAR)))) - { + if ((err = glob1(patbuf, patbuf+MAXPATHLEN-1, pglob, &limit)) != 0) { + pglob->gl_flags = oldflags; + return(err); + } + + /* + * If there was no match we are going to append the pattern + * if GLOB_NOCHECK was specified or if GLOB_NOMAGIC was specified + * and the pattern did not contain any magic characters + * GLOB_NOMAGIC is there just for compatibility with csh. + */ + if (pglob->gl_pathc == oldpathc && + ((pglob->gl_flags & GLOB_NOCHECK) || + ((pglob->gl_flags & GLOB_NOMAGIC) && + !(pglob->gl_flags & GLOB_MAGCHAR)))) + { #ifdef GLOB_DEBUG - printf("calling globextend from glob0\n"); + printf("calling globextend from glob0\n"); #endif /* GLOB_DEBUG */ - pglob->gl_flags = oldflags; - return(globextend(qpat, pglob, &limit)); + pglob->gl_flags = oldflags; + return(globextend(qpat, pglob, &limit)); } - else if (!(pglob->gl_flags & GLOB_NOSORT)) + else if (!(pglob->gl_flags & GLOB_NOSORT)) if (pglob->gl_pathv) - qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc, - pglob->gl_pathc - oldpathc, sizeof(char *), - (pglob->gl_flags & (GLOB_ALPHASORT|GLOB_NOCASE)) - ? ci_compare : compare); - pglob->gl_flags = oldflags; - return(0); + qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc, + pglob->gl_pathc - oldpathc, sizeof(char *), + (pglob->gl_flags & (GLOB_ALPHASORT|GLOB_NOCASE)) + ? ci_compare : compare); + pglob->gl_flags = oldflags; + return(0); } static int ci_compare(const void *p, const void *q) { - const char *pp = *(const char **)p; - const char *qq = *(const char **)q; - int ci; - while (*pp && *qq) { - if (toFOLD(*pp) != toFOLD(*qq)) - break; - ++pp; - ++qq; - } - ci = toFOLD(*pp) - toFOLD(*qq); - if (ci == 0) - return compare(p, q); - return ci; + const char *pp = *(const char **)p; + const char *qq = *(const char **)q; + int ci; + while (*pp && *qq) { + if (toFOLD(*pp) != toFOLD(*qq)) + break; + ++pp; + ++qq; + } + ci = toFOLD(*pp) - toFOLD(*qq); + if (ci == 0) + return compare(p, q); + return ci; } static int compare(const void *p, const void *q) { - return(strcmp(*(char **)p, *(char **)q)); + return(strcmp(*(char **)p, *(char **)q)); } static int glob1(Char *pattern, Char *pattern_last, glob_t *pglob, size_t *limitp) { - Char pathbuf[MAXPATHLEN]; + Char pathbuf[MAXPATHLEN]; assert(pattern < pattern_last); - /* A null pathname is invalid -- POSIX 1003.1 sect. 2.4. */ - if (*pattern == BG_EOS) - return(0); - return(glob2(pathbuf, pathbuf+MAXPATHLEN-1, - pathbuf, pathbuf+MAXPATHLEN-1, - pattern, pattern_last, pglob, limitp)); + /* A null pathname is invalid -- POSIX 1003.1 sect. 2.4. */ + if (*pattern == BG_EOS) + return(0); + return(glob2(pathbuf, pathbuf+MAXPATHLEN-1, + pathbuf, pathbuf+MAXPATHLEN-1, + pattern, pattern_last, pglob, limitp)); } /* @@ -661,79 +661,79 @@ static int glob2(Char *pathbuf, Char *pathbuf_last, Char *pathend, Char *pathend_last, Char *pattern, Char *pattern_last, glob_t *pglob, size_t *limitp) { - Stat_t sb; - Char *p, *q; - int anymeta; + Stat_t sb; + Char *p, *q; + int anymeta; assert(pattern < pattern_last); - /* - * Loop over pattern segments until end of pattern or until - * segment with meta character found. - */ - for (anymeta = 0;;) { - if (*pattern == BG_EOS) { /* End of pattern? */ - *pathend = BG_EOS; - if (g_lstat(pathbuf, &sb, pglob)) - return(0); - - if (((pglob->gl_flags & GLOB_MARK) && - pathend[-1] != BG_SEP + /* + * Loop over pattern segments until end of pattern or until + * segment with meta character found. + */ + for (anymeta = 0;;) { + if (*pattern == BG_EOS) { /* End of pattern? */ + *pathend = BG_EOS; + if (g_lstat(pathbuf, &sb, pglob)) + return(0); + + if (((pglob->gl_flags & GLOB_MARK) && + pathend[-1] != BG_SEP #ifdef DOSISH - && pathend[-1] != BG_SEP2 + && pathend[-1] != BG_SEP2 #endif - ) && (S_ISDIR(sb.st_mode) || - (S_ISLNK(sb.st_mode) && - (g_stat(pathbuf, &sb, pglob) == 0) && - S_ISDIR(sb.st_mode)))) { - if (pathend+1 > pathend_last) - return (1); - *pathend++ = BG_SEP; - *pathend = BG_EOS; - } - ++pglob->gl_matchc; + ) && (S_ISDIR(sb.st_mode) || + (S_ISLNK(sb.st_mode) && + (g_stat(pathbuf, &sb, pglob) == 0) && + S_ISDIR(sb.st_mode)))) { + if (pathend+1 > pathend_last) + return (1); + *pathend++ = BG_SEP; + *pathend = BG_EOS; + } + ++pglob->gl_matchc; #ifdef GLOB_DEBUG printf("calling globextend from glob2\n"); #endif /* GLOB_DEBUG */ - return(globextend(pathbuf, pglob, limitp)); - } + return(globextend(pathbuf, pglob, limitp)); + } - /* Find end of next segment, copy tentatively to pathend. */ - q = pathend; - p = pattern; - while (*p != BG_EOS && *p != BG_SEP + /* Find end of next segment, copy tentatively to pathend. */ + q = pathend; + p = pattern; + while (*p != BG_EOS && *p != BG_SEP #ifdef DOSISH - && *p != BG_SEP2 + && *p != BG_SEP2 #endif - ) { + ) { assert(p < pattern_last); - if (ismeta(*p)) - anymeta = 1; - if (q+1 > pathend_last) - return (1); - *q++ = *p++; - } - - if (!anymeta) { /* No expansion, do next segment. */ - pathend = q; - pattern = p; - while (*pattern == BG_SEP + if (ismeta(*p)) + anymeta = 1; + if (q+1 > pathend_last) + return (1); + *q++ = *p++; + } + + if (!anymeta) { /* No expansion, do next segment. */ + pathend = q; + pattern = p; + while (*pattern == BG_SEP #ifdef DOSISH - || *pattern == BG_SEP2 + || *pattern == BG_SEP2 #endif - ) { + ) { assert(p < pattern_last); - if (pathend+1 > pathend_last) - return (1); - *pathend++ = *pattern++; - } - } else - /* Need expansion, recurse. */ - return(glob3(pathbuf, pathbuf_last, pathend, - pathend_last, pattern, - p, pattern_last, pglob, limitp)); - } - /* NOTREACHED */ + if (pathend+1 > pathend_last) + return (1); + *pathend++ = *pattern++; + } + } else + /* Need expansion, recurse. */ + return(glob3(pathbuf, pathbuf_last, pathend, + pathend_last, pattern, + p, pattern_last, pglob, limitp)); + } + /* NOTREACHED */ } static int @@ -741,97 +741,97 @@ glob3(Char *pathbuf, Char *pathbuf_last, Char *pathend, Char *pathend_last, Char *pattern, Char *restpattern, Char *restpattern_last, glob_t *pglob, size_t *limitp) { - Direntry_t *dp; - DIR *dirp; - int err; - int nocase; - char buf[MAXPATHLEN]; - - /* - * The readdirfunc declaration can't be prototyped, because it is - * assigned, below, to two functions which are prototyped in glob.h - * and dirent.h as taking pointers to differently typed opaque - * structures. - */ - Direntry_t *(*readdirfunc)(DIR*); + Direntry_t *dp; + DIR *dirp; + int err; + int nocase; + char buf[MAXPATHLEN]; + + /* + * The readdirfunc declaration can't be prototyped, because it is + * assigned, below, to two functions which are prototyped in glob.h + * and dirent.h as taking pointers to differently typed opaque + * structures. + */ + Direntry_t *(*readdirfunc)(DIR*); assert(pattern < restpattern_last); assert(restpattern < restpattern_last); - if (pathend > pathend_last) - return (1); - *pathend = BG_EOS; - errno = 0; + if (pathend > pathend_last) + return (1); + *pathend = BG_EOS; + errno = 0; #ifdef VMS { - Char *q = pathend; - if (q - pathbuf > 5) { - q -= 5; - if (q[0] == '.' && - tolower(q[1]) == 'd' && tolower(q[2]) == 'i' && - tolower(q[3]) == 'r' && q[4] == '/') - { - q[0] = '/'; - q[1] = BG_EOS; - pathend = q+1; - } - } + Char *q = pathend; + if (q - pathbuf > 5) { + q -= 5; + if (q[0] == '.' && + tolower(q[1]) == 'd' && tolower(q[2]) == 'i' && + tolower(q[3]) == 'r' && q[4] == '/') + { + q[0] = '/'; + q[1] = BG_EOS; + pathend = q+1; + } + } } #endif - if ((dirp = g_opendir(pathbuf, pglob)) == NULL) { - /* TODO: don't call for ENOENT or ENOTDIR? */ - if (pglob->gl_errfunc) { - if (g_Ctoc(pathbuf, buf, sizeof(buf))) - return (GLOB_ABEND); - if (pglob->gl_errfunc(buf, errno) || - (pglob->gl_flags & GLOB_ERR)) - return (GLOB_ABEND); - } - return(0); - } - - err = 0; - nocase = ((pglob->gl_flags & GLOB_NOCASE) != 0); - - /* Search directory for matching names. */ - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - readdirfunc = (Direntry_t *(*)(DIR *))pglob->gl_readdir; - else - readdirfunc = (Direntry_t *(*)(DIR *))my_readdir; - while ((dp = (*readdirfunc)(dirp))) { - U8 *sc; - Char *dc; - - /* Initial BG_DOT must be matched literally. */ - if (dp->d_name[0] == BG_DOT && *pattern != BG_DOT) - continue; - dc = pathend; - sc = (U8 *) dp->d_name; - while (dc < pathend_last && (*dc++ = *sc++) != BG_EOS) - ; - if (dc >= pathend_last) { - *dc = BG_EOS; - err = 1; - break; - } - - if (!match(pathend, pattern, restpattern, nocase)) { - *pathend = BG_EOS; - continue; - } - err = glob2(pathbuf, pathbuf_last, --dc, pathend_last, - restpattern, restpattern_last, pglob, limitp); - if (err) - break; - } - - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - (*pglob->gl_closedir)(dirp); - else - PerlDir_close(dirp); - return(err); + if ((dirp = g_opendir(pathbuf, pglob)) == NULL) { + /* TODO: don't call for ENOENT or ENOTDIR? */ + if (pglob->gl_errfunc) { + if (g_Ctoc(pathbuf, buf, sizeof(buf))) + return (GLOB_ABEND); + if (pglob->gl_errfunc(buf, errno) || + (pglob->gl_flags & GLOB_ERR)) + return (GLOB_ABEND); + } + return(0); + } + + err = 0; + nocase = ((pglob->gl_flags & GLOB_NOCASE) != 0); + + /* Search directory for matching names. */ + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + readdirfunc = (Direntry_t *(*)(DIR *))pglob->gl_readdir; + else + readdirfunc = (Direntry_t *(*)(DIR *))my_readdir; + while ((dp = (*readdirfunc)(dirp))) { + U8 *sc; + Char *dc; + + /* Initial BG_DOT must be matched literally. */ + if (dp->d_name[0] == BG_DOT && *pattern != BG_DOT) + continue; + dc = pathend; + sc = (U8 *) dp->d_name; + while (dc < pathend_last && (*dc++ = *sc++) != BG_EOS) + ; + if (dc >= pathend_last) { + *dc = BG_EOS; + err = 1; + break; + } + + if (!match(pathend, pattern, restpattern, nocase)) { + *pathend = BG_EOS; + continue; + } + err = glob2(pathbuf, pathbuf_last, --dc, pathend_last, + restpattern, restpattern_last, pglob, limitp); + if (err) + break; + } + + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + (*pglob->gl_closedir)(dirp); + else + PerlDir_close(dirp); + return(err); } @@ -852,61 +852,61 @@ glob3(Char *pathbuf, Char *pathbuf_last, Char *pathend, Char *pathend_last, static int globextend(const Char *path, glob_t *pglob, size_t *limitp) { - char **pathv; - int i; - STRLEN newsize, len; - char *copy; - const Char *p; + char **pathv; + int i; + STRLEN newsize, len; + char *copy; + const Char *p; #ifdef GLOB_DEBUG - printf("Adding "); + printf("Adding "); for (p = path; *p; p++) (void)printf("%c", CHAR(*p)); printf("\n"); #endif /* GLOB_DEBUG */ - newsize = sizeof(*pathv) * (2 + pglob->gl_pathc + pglob->gl_offs); - if (pglob->gl_pathv) - pathv = Renew(pglob->gl_pathv,newsize,char*); - else - Newx(pathv,newsize,char*); - if (pathv == NULL) { - if (pglob->gl_pathv) { - Safefree(pglob->gl_pathv); - pglob->gl_pathv = NULL; - } - return(GLOB_NOSPACE); - } - - if (pglob->gl_pathv == NULL && pglob->gl_offs > 0) { - /* first time around -- clear initial gl_offs items */ - pathv += pglob->gl_offs; - for (i = pglob->gl_offs; --i >= 0; ) - *--pathv = NULL; - } - pglob->gl_pathv = pathv; - - for (p = path; *p++;) - ; - len = (STRLEN)(p - path); - *limitp += len; - Newx(copy, p-path, char); - if (copy != NULL) { - if (g_Ctoc(path, copy, len)) { - Safefree(copy); - return(GLOB_NOSPACE); - } - pathv[pglob->gl_offs + pglob->gl_pathc++] = copy; - } - pathv[pglob->gl_offs + pglob->gl_pathc] = NULL; - - if ((pglob->gl_flags & GLOB_LIMIT) && - newsize + *limitp >= (unsigned long)ARG_MAX) { - errno = 0; - return(GLOB_NOSPACE); - } - - return(copy == NULL ? GLOB_NOSPACE : 0); + newsize = sizeof(*pathv) * (2 + pglob->gl_pathc + pglob->gl_offs); + if (pglob->gl_pathv) + pathv = Renew(pglob->gl_pathv,newsize,char*); + else + Newx(pathv,newsize,char*); + if (pathv == NULL) { + if (pglob->gl_pathv) { + Safefree(pglob->gl_pathv); + pglob->gl_pathv = NULL; + } + return(GLOB_NOSPACE); + } + + if (pglob->gl_pathv == NULL && pglob->gl_offs > 0) { + /* first time around -- clear initial gl_offs items */ + pathv += pglob->gl_offs; + for (i = pglob->gl_offs; --i >= 0; ) + *--pathv = NULL; + } + pglob->gl_pathv = pathv; + + for (p = path; *p++;) + ; + len = (STRLEN)(p - path); + *limitp += len; + Newx(copy, p-path, char); + if (copy != NULL) { + if (g_Ctoc(path, copy, len)) { + Safefree(copy); + return(GLOB_NOSPACE); + } + pathv[pglob->gl_offs + pglob->gl_pathc++] = copy; + } + pathv[pglob->gl_offs + pglob->gl_pathc] = NULL; + + if ((pglob->gl_flags & GLOB_LIMIT) && + newsize + *limitp >= (unsigned long)ARG_MAX) { + errno = 0; + return(GLOB_NOSPACE); + } + + return(copy == NULL ? GLOB_NOSPACE : 0); } @@ -930,171 +930,171 @@ globextend(const Char *path, glob_t *pglob, size_t *limitp) static int match(Char *name, Char *pat, Char *patend, int nocase) { - int ok, negate_range; - Char c, k; - Char *nextp = NULL; - Char *nextn = NULL; + int ok, negate_range; + Char c, k; + Char *nextp = NULL; + Char *nextn = NULL; redo: - while (pat < patend) { - c = *pat++; - switch (c & M_MASK) { - case M_ALL: - if (pat == patend) - return(1); - if (*name == BG_EOS) - return 0; - nextn = name + 1; - nextp = pat - 1; - break; - case M_ONE: + while (pat < patend) { + c = *pat++; + switch (c & M_MASK) { + case M_ALL: + if (pat == patend) + return(1); + if (*name == BG_EOS) + return 0; + nextn = name + 1; + nextp = pat - 1; + break; + case M_ONE: /* since * matches leftmost-shortest first * * if we encounter the EOS then backtracking * * will not help, so we can exit early here. */ - if (*name++ == BG_EOS) + if (*name++ == BG_EOS) return 0; - break; - case M_SET: - ok = 0; + break; + case M_SET: + ok = 0; /* since * matches leftmost-shortest first * * if we encounter the EOS then backtracking * * will not help, so we can exit early here. */ - if ((k = *name++) == BG_EOS) + if ((k = *name++) == BG_EOS) return 0; - if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS) - ++pat; - while (((c = *pat++) & M_MASK) != M_END) - if ((*pat & M_MASK) == M_RNG) { - if (nocase) { - if (tolower(c) <= tolower(k) && tolower(k) <= tolower(pat[1])) - ok = 1; - } else { - if (c <= k && k <= pat[1]) - ok = 1; - } - pat += 2; - } else if (nocase ? (tolower(c) == tolower(k)) : (c == k)) - ok = 1; - if (ok == negate_range) - goto fail; - break; - default: - k = *name++; - if (nocase ? (tolower(k) != tolower(c)) : (k != c)) - goto fail; - break; - } - } - if (*name == BG_EOS) - return 1; + if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS) + ++pat; + while (((c = *pat++) & M_MASK) != M_END) + if ((*pat & M_MASK) == M_RNG) { + if (nocase) { + if (tolower(c) <= tolower(k) && tolower(k) <= tolower(pat[1])) + ok = 1; + } else { + if (c <= k && k <= pat[1]) + ok = 1; + } + pat += 2; + } else if (nocase ? (tolower(c) == tolower(k)) : (c == k)) + ok = 1; + if (ok == negate_range) + goto fail; + break; + default: + k = *name++; + if (nocase ? (tolower(k) != tolower(c)) : (k != c)) + goto fail; + break; + } + } + if (*name == BG_EOS) + return 1; fail: - if (nextn) { - pat = nextp; - name = nextn; - goto redo; - } - return 0; + if (nextn) { + pat = nextp; + name = nextn; + goto redo; + } + return 0; } /* Free allocated data belonging to a glob_t structure. */ void bsd_globfree(glob_t *pglob) { - int i; - char **pp; - - if (pglob->gl_pathv != NULL) { - pp = pglob->gl_pathv + pglob->gl_offs; - for (i = pglob->gl_pathc; i--; ++pp) - if (*pp) - Safefree(*pp); - Safefree(pglob->gl_pathv); - pglob->gl_pathv = NULL; - } + int i; + char **pp; + + if (pglob->gl_pathv != NULL) { + pp = pglob->gl_pathv + pglob->gl_offs; + for (i = pglob->gl_pathc; i--; ++pp) + if (*pp) + Safefree(*pp); + Safefree(pglob->gl_pathv); + pglob->gl_pathv = NULL; + } } static DIR * g_opendir(Char *str, glob_t *pglob) { - char buf[MAXPATHLEN]; + char buf[MAXPATHLEN]; - if (!*str) { - my_strlcpy(buf, ".", sizeof(buf)); - } else { - if (g_Ctoc(str, buf, sizeof(buf))) - return(NULL); - } + if (!*str) { + my_strlcpy(buf, ".", sizeof(buf)); + } else { + if (g_Ctoc(str, buf, sizeof(buf))) + return(NULL); + } - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - return((DIR*)(*pglob->gl_opendir)(buf)); + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + return((DIR*)(*pglob->gl_opendir)(buf)); - return(PerlDir_open(buf)); + return(PerlDir_open(buf)); } static int g_lstat(Char *fn, Stat_t *sb, glob_t *pglob) { - char buf[MAXPATHLEN]; + char buf[MAXPATHLEN]; - if (g_Ctoc(fn, buf, sizeof(buf))) - return(-1); - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - return((*pglob->gl_lstat)(buf, sb)); + if (g_Ctoc(fn, buf, sizeof(buf))) + return(-1); + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + return((*pglob->gl_lstat)(buf, sb)); #ifdef HAS_LSTAT - return(PerlLIO_lstat(buf, sb)); + return(PerlLIO_lstat(buf, sb)); #else - return(PerlLIO_stat(buf, sb)); + return(PerlLIO_stat(buf, sb)); #endif /* HAS_LSTAT */ } static int g_stat(Char *fn, Stat_t *sb, glob_t *pglob) { - char buf[MAXPATHLEN]; + char buf[MAXPATHLEN]; - if (g_Ctoc(fn, buf, sizeof(buf))) - return(-1); - if (pglob->gl_flags & GLOB_ALTDIRFUNC) - return((*pglob->gl_stat)(buf, sb)); - return(PerlLIO_stat(buf, sb)); + if (g_Ctoc(fn, buf, sizeof(buf))) + return(-1); + if (pglob->gl_flags & GLOB_ALTDIRFUNC) + return((*pglob->gl_stat)(buf, sb)); + return(PerlLIO_stat(buf, sb)); } static Char * g_strchr(Char *str, int ch) { - do { - if (*str == ch) - return (str); - } while (*str++); - return (NULL); + do { + if (*str == ch) + return (str); + } while (*str++); + return (NULL); } static int g_Ctoc(const Char *str, char *buf, STRLEN len) { - while (len--) { - if ((*buf++ = (char)*str++) == BG_EOS) - return (0); - } - return (1); + while (len--) { + if ((*buf++ = (char)*str++) == BG_EOS) + return (0); + } + return (1); } #ifdef GLOB_DEBUG static void qprintf(const char *str, Char *s) { - Char *p; - - (void)printf("%s:\n", str); - for (p = s; *p; p++) - (void)printf("%c", CHAR(*p)); - (void)printf("\n"); - for (p = s; *p; p++) - (void)printf("%c", *p & M_PROTECT ? '"' : ' '); - (void)printf("\n"); - for (p = s; *p; p++) - (void)printf("%c", ismeta(*p) ? '_' : ' '); - (void)printf("\n"); + Char *p; + + (void)printf("%s:\n", str); + for (p = s; *p; p++) + (void)printf("%c", CHAR(*p)); + (void)printf("\n"); + for (p = s; *p; p++) + (void)printf("%c", *p & M_PROTECT ? '"' : ' '); + (void)printf("\n"); + for (p = s; *p; p++) + (void)printf("%c", ismeta(*p) ? '_' : ' '); + (void)printf("\n"); } #endif /* GLOB_DEBUG */ diff --git a/ext/File-Glob/bsd_glob.h b/ext/File-Glob/bsd_glob.h index c913cff9d8..424591c925 100644 --- a/ext/File-Glob/bsd_glob.h +++ b/ext/File-Glob/bsd_glob.h @@ -39,24 +39,24 @@ /* #include <sys/cdefs.h> */ typedef struct { - int gl_pathc; /* Count of total paths so far. */ - int gl_matchc; /* Count of paths matching pattern. */ - int gl_offs; /* Reserved at beginning of gl_pathv. */ - int gl_flags; /* Copy of flags parameter to glob. */ - char **gl_pathv; /* List of paths matching pattern. */ - /* Copy of errfunc parameter to glob. */ - int (*gl_errfunc)(const char *, int); + int gl_pathc; /* Count of total paths so far. */ + int gl_matchc; /* Count of paths matching pattern. */ + int gl_offs; /* Reserved at beginning of gl_pathv. */ + int gl_flags; /* Copy of flags parameter to glob. */ + char **gl_pathv; /* List of paths matching pattern. */ + /* Copy of errfunc parameter to glob. */ + int (*gl_errfunc)(const char *, int); - /* - * Alternate filesystem access methods for glob; replacement - * versions of closedir(3), readdir(3), opendir(3), stat(2) - * and lstat(2). - */ - void (*gl_closedir)(void *); - Direntry_t *(*gl_readdir)(void *); - void *(*gl_opendir)(const char *); - int (*gl_lstat)(const char *, Stat_t *); - int (*gl_stat)(const char *, Stat_t *); + /* + * Alternate filesystem access methods for glob; replacement + * versions of closedir(3), readdir(3), opendir(3), stat(2) + * and lstat(2). + */ + void (*gl_closedir)(void *); + Direntry_t *(*gl_readdir)(void *); + void *(*gl_opendir)(const char *); + int (*gl_lstat)(const char *, Stat_t *); + int (*gl_stat)(const char *, Stat_t *); } glob_t; #define GLOB_APPEND 0x0001 /* Append to output from previous call. */ @@ -75,7 +75,7 @@ typedef struct { #define GLOB_NOCASE 0x1000 /* Treat filenames without regard for case. */ #define GLOB_ALPHASORT 0x2000 /* Alphabetic, not ASCII sort, like csh. */ #define GLOB_LIMIT 0x4000 /* Limit pattern match output to ARG_MAX - (usually from limits.h). */ + (usually from limits.h). */ #define GLOB_NOSPACE (-1) /* Malloc call failed. */ #define GLOB_ABEND (-2) /* Unignored error. */ diff --git a/ext/SDBM_File/dba.c b/ext/SDBM_File/dba.c index b27c3e66a4..8462213724 100644 --- a/ext/SDBM_File/dba.c +++ b/ext/SDBM_File/dba.c @@ -13,75 +13,75 @@ extern void oops(); int main(int argc, char **argv) { - int n; - char *p; - char *name; - int pagf; + int n; + char *p; + char *name; + int pagf; - progname = argv[0]; + progname = argv[0]; - if (p = argv[1]) { - name = (char *) malloc((n = strlen(p)) + 5); - if (!name) - oops("cannot get memory"); + if (p = argv[1]) { + name = (char *) malloc((n = strlen(p)) + 5); + if (!name) + oops("cannot get memory"); - strcpy(name, p); - strcpy(name + n, ".pag"); + strcpy(name, p); + strcpy(name + n, ".pag"); - if ((pagf = open(name, O_RDONLY)) < 0) - oops("cannot open %s.", name); + if ((pagf = open(name, O_RDONLY)) < 0) + oops("cannot open %s.", name); - sdump(pagf); - } - else - oops("usage: %s dbname", progname); + sdump(pagf); + } + else + oops("usage: %s dbname", progname); - return 0; + return 0; } void sdump(int pagf) { - int b; - int n = 0; - int t = 0; - int o = 0; - int e; - char pag[PBLKSIZ]; + int b; + int n = 0; + int t = 0; + int o = 0; + int e; + char pag[PBLKSIZ]; - while ((b = read(pagf, pag, PBLKSIZ)) > 0) { - printf("#%d: ", n); - if (!okpage(pag)) - printf("bad\n"); - else { - printf("ok. "); - if (!(e = pagestat(pag))) - o++; - else - t += e; - } - n++; - } + while ((b = read(pagf, pag, PBLKSIZ)) > 0) { + printf("#%d: ", n); + if (!okpage(pag)) + printf("bad\n"); + else { + printf("ok. "); + if (!(e = pagestat(pag))) + o++; + else + t += e; + } + n++; + } - if (b == 0) - printf("%d pages (%d holes): %d entries\n", n, o, t); - else - oops("read failed: block %d", n); + if (b == 0) + printf("%d pages (%d holes): %d entries\n", n, o, t); + else + oops("read failed: block %d", n); } int pagestat(char *pag) { - int n; - int free; - short *ino = (short *) pag; + int n; + int free; + short *ino = (short *) pag; - if (!(n = ino[0])) - printf("no entries.\n"); - else { - free = ino[n] - (n + 1) * sizeof(short); - printf("%3d entries %2d%% used free %d.\n", - n / 2, ((PBLKSIZ - free) * 100) / PBLKSIZ, free); - } - return n / 2; + if (!(n = ino[0])) + printf("no entries.\n"); + else { + free = ino[n] - (n + 1) * sizeof(short); + printf("%3d entries %2d%% used free %d.\n", + n / 2, ((PBLKSIZ - free) * 100) / PBLKSIZ, free); + } + return n / 2; } diff --git a/ext/SDBM_File/dbd.c b/ext/SDBM_File/dbd.c index df27d174a8..bd64d90a18 100644 --- a/ext/SDBM_File/dbd.c +++ b/ext/SDBM_File/dbd.c @@ -16,53 +16,53 @@ extern void oops(); int main(int argc, char **argv) { - int n; - char *p; - char *name; - int pagf; + int n; + char *p; + char *name; + int pagf; - progname = argv[0]; + progname = argv[0]; - if (p = argv[1]) { - name = (char *) malloc((n = strlen(p)) + 5); - if (!name) - oops("cannot get memory"); + if (p = argv[1]) { + name = (char *) malloc((n = strlen(p)) + 5); + if (!name) + oops("cannot get memory"); - strcpy(name, p); - strcpy(name + n, ".pag"); + strcpy(name, p); + strcpy(name + n, ".pag"); - if ((pagf = open(name, O_RDONLY)) < 0) - oops("cannot open %s.", name); + if ((pagf = open(name, O_RDONLY)) < 0) + oops("cannot open %s.", name); - sdump(pagf); - } - else - oops("usage: %s dbname", progname); - return 0; + sdump(pagf); + } + else + oops("usage: %s dbname", progname); + return 0; } void sdump(int pagf) { - int r; - int n = 0; - int o = 0; - char pag[PBLKSIZ]; - - while ((r = read(pagf, pag, PBLKSIZ)) > 0) { - if (!okpage(pag)) - fprintf(stderr, "%d: bad page.\n", n); - else if (empty(pag)) - o++; - else - dispage(pag); - n++; - } - - if (r == 0) - fprintf(stderr, "%d pages (%d holes).\n", n, o); - else - oops("read failed: block %d", n); + int r; + int n = 0; + int o = 0; + char pag[PBLKSIZ]; + + while ((r = read(pagf, pag, PBLKSIZ)) > 0) { + if (!okpage(pag)) + fprintf(stderr, "%d: bad page.\n", n); + else if (empty(pag)) + o++; + else + dispage(pag); + n++; + } + + if (r == 0) + fprintf(stderr, "%d pages (%d holes).\n", n, o); + else + oops("read failed: block %d", n); } @@ -70,44 +70,44 @@ sdump(int pagf) int dispage(char *pag) { - int i, n; - int off; - int short *ino = (short *) pag; - - off = PBLKSIZ; - for (i = 1; i < ino[0]; i += 2) { - printf("\t[%d]: ", ino[i]); - for (n = ino[i]; n < off; n++) - putchar(pag[n]); - putchar(' '); - off = ino[i]; - printf("[%d]: ", ino[i + 1]); - for (n = ino[i + 1]; n < off; n++) - putchar(pag[n]); - off = ino[i + 1]; - putchar('\n'); - } + int i, n; + int off; + int short *ino = (short *) pag; + + off = PBLKSIZ; + for (i = 1; i < ino[0]; i += 2) { + printf("\t[%d]: ", ino[i]); + for (n = ino[i]; n < off; n++) + putchar(pag[n]); + putchar(' '); + off = ino[i]; + printf("[%d]: ", ino[i + 1]); + for (n = ino[i + 1]; n < off; n++) + putchar(pag[n]); + off = ino[i + 1]; + putchar('\n'); + } } #else void dispage(char *pag) { - int i, n; - int off; - short *ino = (short *) pag; - - off = PBLKSIZ; - for (i = 1; i < ino[0]; i += 2) { - for (n = ino[i]; n < off; n++) - if (pag[n] != 0) - putchar(pag[n]); - putchar('\t'); - off = ino[i]; - for (n = ino[i + 1]; n < off; n++) - if (pag[n] != 0) - putchar(pag[n]); - putchar('\n'); - off = ino[i + 1]; - } + int i, n; + int off; + short *ino = (short *) pag; + + off = PBLKSIZ; + for (i = 1; i < ino[0]; i += 2) { + for (n = ino[i]; n < off; n++) + if (pag[n] != 0) + putchar(pag[n]); + putchar('\t'); + off = ino[i]; + for (n = ino[i + 1]; n < off; n++) + if (pag[n] != 0) + putchar(pag[n]); + putchar('\n'); + off = ino[i + 1]; + } } #endif diff --git a/ext/SDBM_File/dbe.c b/ext/SDBM_File/dbe.c index d1e3bd5e77..a53346b67e 100644 --- a/ext/SDBM_File/dbe.c +++ b/ext/SDBM_File/dbe.c @@ -51,381 +51,381 @@ char *optarg; /* Global argument pointer. */ char getopt(int argc, char **argv, char *optstring) { - int c; - char *place; - static int optind = 0; - static char *scan = NULL; - - optarg = NULL; - - if (scan == NULL || *scan == '\0') { - - if (optind == 0) - optind++; - if (optind >= argc) - return ':'; - - optarg = place = argv[optind++]; - if (place[0] != '-' || place[1] == '\0') - return '?'; - if (place[1] == '-' && place[2] == '\0') - return '?'; - scan = place + 1; - } - - c = *scan++; - place = strchr(optstring, c); - if (place == NULL || c == ':' || c == ';') { - - (void) fprintf(stderr, "%s: unknown option %c\n", argv[0], c); - scan = NULL; - return '!'; - } - if (*++place == ':') { - - if (*scan != '\0') { - - optarg = scan; - scan = NULL; - - } - else { - - if (optind >= argc) { - - (void) fprintf(stderr, "%s: %c requires an argument\n", - argv[0], c); - return '!'; - } - optarg = argv[optind]; - optind++; - } - } - else if (*place == ';') { - - if (*scan != '\0') { - - optarg = scan; - scan = NULL; - - } - else { - - if (optind >= argc || *argv[optind] == '-') - optarg = NULL; - else { - optarg = argv[optind]; - optind++; - } - } - } - return c; + int c; + char *place; + static int optind = 0; + static char *scan = NULL; + + optarg = NULL; + + if (scan == NULL || *scan == '\0') { + + if (optind == 0) + optind++; + if (optind >= argc) + return ':'; + + optarg = place = argv[optind++]; + if (place[0] != '-' || place[1] == '\0') + return '?'; + if (place[1] == '-' && place[2] == '\0') + return '?'; + scan = place + 1; + } + + c = *scan++; + place = strchr(optstring, c); + if (place == NULL || c == ':' || c == ';') { + + (void) fprintf(stderr, "%s: unknown option %c\n", argv[0], c); + scan = NULL; + return '!'; + } + if (*++place == ':') { + + if (*scan != '\0') { + + optarg = scan; + scan = NULL; + + } + else { + + if (optind >= argc) { + + (void) fprintf(stderr, "%s: %c requires an argument\n", + argv[0], c); + return '!'; + } + optarg = argv[optind]; + optind++; + } + } + else if (*place == ';') { + + if (*scan != '\0') { + + optarg = scan; + scan = NULL; + + } + else { + + if (optind >= argc || *argv[optind] == '-') + optarg = NULL; + else { + optarg = argv[optind]; + optind++; + } + } + } + return c; } void print_datum(datum db) { - int i; - - putchar('"'); - for (i = 0; i < db.dsize; i++) { - if (isprint((unsigned char)db.dptr[i])) - putchar(db.dptr[i]); - else { - putchar('\\'); - putchar('0' + ((db.dptr[i] >> 6) & 0x07)); - putchar('0' + ((db.dptr[i] >> 3) & 0x07)); - putchar('0' + (db.dptr[i] & 0x07)); - } - } - putchar('"'); + int i; + + putchar('"'); + for (i = 0; i < db.dsize; i++) { + if (isprint((unsigned char)db.dptr[i])) + putchar(db.dptr[i]); + else { + putchar('\\'); + putchar('0' + ((db.dptr[i] >> 6) & 0x07)); + putchar('0' + ((db.dptr[i] >> 3) & 0x07)); + putchar('0' + (db.dptr[i] & 0x07)); + } + } + putchar('"'); } datum read_datum(char *s) { - datum db; - char *p; - int i; - - db.dsize = 0; - db.dptr = (char *) malloc(strlen(s) * sizeof(char)); - if (!db.dptr) - oops("cannot get memory"); - - for (p = db.dptr; *s != '\0'; p++, db.dsize++, s++) { - if (*s == '\\') { - if (*++s == 'n') - *p = '\n'; - else if (*s == 'r') - *p = '\r'; - else if (*s == 'f') - *p = '\f'; - else if (*s == 't') - *p = '\t'; - else if (isdigit((unsigned char)*s) - && isdigit((unsigned char)*(s + 1)) - && isdigit((unsigned char)*(s + 2))) - { - i = (*s++ - '0') << 6; - i |= (*s++ - '0') << 3; - i |= *s - '0'; - *p = i; - } - else if (*s == '0') - *p = '\0'; - else - *p = *s; - } - else - *p = *s; - } - - return db; + datum db; + char *p; + int i; + + db.dsize = 0; + db.dptr = (char *) malloc(strlen(s) * sizeof(char)); + if (!db.dptr) + oops("cannot get memory"); + + for (p = db.dptr; *s != '\0'; p++, db.dsize++, s++) { + if (*s == '\\') { + if (*++s == 'n') + *p = '\n'; + else if (*s == 'r') + *p = '\r'; + else if (*s == 'f') + *p = '\f'; + else if (*s == 't') + *p = '\t'; + else if (isdigit((unsigned char)*s) + && isdigit((unsigned char)*(s + 1)) + && isdigit((unsigned char)*(s + 2))) + { + i = (*s++ - '0') << 6; + i |= (*s++ - '0') << 3; + i |= *s - '0'; + *p = i; + } + else if (*s == '0') + *p = '\0'; + else + *p = *s; + } + else + *p = *s; + } + + return db; } char * key2s(datum db) { - char *buf; - char *p1, *p2; - - buf = (char *) malloc((db.dsize + 1) * sizeof(char)); - if (!buf) - oops("cannot get memory"); - for (p1 = buf, p2 = db.dptr; *p2 != '\0'; *p1++ = *p2++); - *p1 = '\0'; - return buf; + char *buf; + char *p1, *p2; + + buf = (char *) malloc((db.dsize + 1) * sizeof(char)); + if (!buf) + oops("cannot get memory"); + for (p1 = buf, p2 = db.dptr; *p2 != '\0'; *p1++ = *p2++); + *p1 = '\0'; + return buf; } int main(int argc, char **argv) { - typedef enum { - YOW, FETCH, STORE, DELETE, SCAN, REGEXP - } commands; - char opt; - int flags; - int giveusage = 0; - int verbose = 0; - commands what = YOW; - char *comarg[3]; - int st_flag = DBM_INSERT; - int argn; - DBM *db; - datum key; - datum content; - - flags = O_RDWR; - argn = 0; - - while ((opt = getopt(argc, argv, "acdfFm:rstvx")) != ':') { - switch (opt) { - case 'a': - what = SCAN; - break; - case 'c': - flags |= O_CREAT; - break; - case 'd': - what = DELETE; - break; - case 'f': - what = FETCH; - break; - case 'F': - what = REGEXP; - break; - case 'm': - flags &= ~(000007); - if (strcmp(optarg, "r") == 0) - flags |= O_RDONLY; - else if (strcmp(optarg, "w") == 0) - flags |= O_WRONLY; - else if (strcmp(optarg, "rw") == 0) - flags |= O_RDWR; - else { - fprintf(stderr, "Invalid mode: \"%s\"\n", optarg); - giveusage = 1; - } - break; - case 'r': - st_flag = DBM_REPLACE; - break; - case 's': - what = STORE; - break; - case 't': - flags |= O_TRUNC; - break; - case 'v': - verbose = 1; - break; - case 'x': - flags |= O_EXCL; - break; - case '!': - giveusage = 1; - break; - case '?': - if (argn < 3) - comarg[argn++] = optarg; - else { - fprintf(stderr, "Too many arguments.\n"); - giveusage = 1; - } - break; - } - } - - if (giveusage || what == YOW || argn < 1) { - fprintf(stderr, "Usage: %s database [-m r|w|rw] [-crtx] -a|-d|-f|-F|-s [key [content]]\n", argv[0]); - exit(-1); - } - - if ((db = dbm_open(comarg[0], flags, 0777)) == NULL) { - fprintf(stderr, "Error opening database \"%s\"\n", comarg[0]); - exit(-1); - } - - if (argn > 1) - key = read_datum(comarg[1]); - if (argn > 2) - content = read_datum(comarg[2]); - - switch (what) { - - case SCAN: - key = dbm_firstkey(db); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching first key\n"); - goto db_exit; - } - while (key.dptr != NULL) { - content = dbm_fetch(db, key); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching "); - print_datum(key); - printf("\n"); - goto db_exit; - } - print_datum(key); - printf(": "); - print_datum(content); - printf("\n"); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching next key\n"); - goto db_exit; - } - key = dbm_nextkey(db); - } - break; - - case REGEXP: - if (argn < 2) { - fprintf(stderr, "Missing regular expression.\n"); - goto db_exit; - } - if (re_comp(comarg[1])) { - fprintf(stderr, "Invalid regular expression\n"); - goto db_exit; - } - key = dbm_firstkey(db); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching first key\n"); - goto db_exit; - } - while (key.dptr != NULL) { - if (re_exec(key2s(key))) { - content = dbm_fetch(db, key); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching "); - print_datum(key); - printf("\n"); - goto db_exit; - } - print_datum(key); - printf(": "); - print_datum(content); - printf("\n"); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching next key\n"); - goto db_exit; - } - } - key = dbm_nextkey(db); - } - break; - - case FETCH: - if (argn < 2) { - fprintf(stderr, "Missing fetch key.\n"); - goto db_exit; - } - content = dbm_fetch(db, key); - if (dbm_error(db)) { - fprintf(stderr, "Error when fetching "); - print_datum(key); - printf("\n"); - goto db_exit; - } - if (content.dptr == NULL) { - fprintf(stderr, "Cannot find "); - print_datum(key); - printf("\n"); - goto db_exit; - } - print_datum(key); - printf(": "); - print_datum(content); - printf("\n"); - break; - - case DELETE: - if (argn < 2) { - fprintf(stderr, "Missing delete key.\n"); - goto db_exit; - } - if (dbm_delete(db, key) || dbm_error(db)) { - fprintf(stderr, "Error when deleting "); - print_datum(key); - printf("\n"); - goto db_exit; - } - if (verbose) { - print_datum(key); - printf(": DELETED\n"); - } - break; - - case STORE: - if (argn < 3) { - fprintf(stderr, "Missing key and/or content.\n"); - goto db_exit; - } - if (dbm_store(db, key, content, st_flag) || dbm_error(db)) { - fprintf(stderr, "Error when storing "); - print_datum(key); - printf("\n"); - goto db_exit; - } - if (verbose) { - print_datum(key); - printf(": "); - print_datum(content); - printf(" STORED\n"); - } - break; - } + typedef enum { + YOW, FETCH, STORE, DELETE, SCAN, REGEXP + } commands; + char opt; + int flags; + int giveusage = 0; + int verbose = 0; + commands what = YOW; + char *comarg[3]; + int st_flag = DBM_INSERT; + int argn; + DBM *db; + datum key; + datum content; + + flags = O_RDWR; + argn = 0; + + while ((opt = getopt(argc, argv, "acdfFm:rstvx")) != ':') { + switch (opt) { + case 'a': + what = SCAN; + break; + case 'c': + flags |= O_CREAT; + break; + case 'd': + what = DELETE; + break; + case 'f': + what = FETCH; + break; + case 'F': + what = REGEXP; + break; + case 'm': + flags &= ~(000007); + if (strcmp(optarg, "r") == 0) + flags |= O_RDONLY; + else if (strcmp(optarg, "w") == 0) + flags |= O_WRONLY; + else if (strcmp(optarg, "rw") == 0) + flags |= O_RDWR; + else { + fprintf(stderr, "Invalid mode: \"%s\"\n", optarg); + giveusage = 1; + } + break; + case 'r': + st_flag = DBM_REPLACE; + break; + case 's': + what = STORE; + break; + case 't': + flags |= O_TRUNC; + break; + case 'v': + verbose = 1; + break; + case 'x': + flags |= O_EXCL; + break; + case '!': + giveusage = 1; + break; + case '?': + if (argn < 3) + comarg[argn++] = optarg; + else { + fprintf(stderr, "Too many arguments.\n"); + giveusage = 1; + } + break; + } + } + + if (giveusage || what == YOW || argn < 1) { + fprintf(stderr, "Usage: %s database [-m r|w|rw] [-crtx] -a|-d|-f|-F|-s [key [content]]\n", argv[0]); + exit(-1); + } + + if ((db = dbm_open(comarg[0], flags, 0777)) == NULL) { + fprintf(stderr, "Error opening database \"%s\"\n", comarg[0]); + exit(-1); + } + + if (argn > 1) + key = read_datum(comarg[1]); + if (argn > 2) + content = read_datum(comarg[2]); + + switch (what) { + + case SCAN: + key = dbm_firstkey(db); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching first key\n"); + goto db_exit; + } + while (key.dptr != NULL) { + content = dbm_fetch(db, key); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching "); + print_datum(key); + printf("\n"); + goto db_exit; + } + print_datum(key); + printf(": "); + print_datum(content); + printf("\n"); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching next key\n"); + goto db_exit; + } + key = dbm_nextkey(db); + } + break; + + case REGEXP: + if (argn < 2) { + fprintf(stderr, "Missing regular expression.\n"); + goto db_exit; + } + if (re_comp(comarg[1])) { + fprintf(stderr, "Invalid regular expression\n"); + goto db_exit; + } + key = dbm_firstkey(db); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching first key\n"); + goto db_exit; + } + while (key.dptr != NULL) { + if (re_exec(key2s(key))) { + content = dbm_fetch(db, key); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching "); + print_datum(key); + printf("\n"); + goto db_exit; + } + print_datum(key); + printf(": "); + print_datum(content); + printf("\n"); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching next key\n"); + goto db_exit; + } + } + key = dbm_nextkey(db); + } + break; + + case FETCH: + if (argn < 2) { + fprintf(stderr, "Missing fetch key.\n"); + goto db_exit; + } + content = dbm_fetch(db, key); + if (dbm_error(db)) { + fprintf(stderr, "Error when fetching "); + print_datum(key); + printf("\n"); + goto db_exit; + } + if (content.dptr == NULL) { + fprintf(stderr, "Cannot find "); + print_datum(key); + printf("\n"); + goto db_exit; + } + print_datum(key); + printf(": "); + print_datum(content); + printf("\n"); + break; + + case DELETE: + if (argn < 2) { + fprintf(stderr, "Missing delete key.\n"); + goto db_exit; + } + if (dbm_delete(db, key) || dbm_error(db)) { + fprintf(stderr, "Error when deleting "); + print_datum(key); + printf("\n"); + goto db_exit; + } + if (verbose) { + print_datum(key); + printf(": DELETED\n"); + } + break; + + case STORE: + if (argn < 3) { + fprintf(stderr, "Missing key and/or content.\n"); + goto db_exit; + } + if (dbm_store(db, key, content, st_flag) || dbm_error(db)) { + fprintf(stderr, "Error when storing "); + print_datum(key); + printf("\n"); + goto db_exit; + } + if (verbose) { + print_datum(key); + printf(": "); + print_datum(content); + printf(" STORED\n"); + } + break; + } db_exit: - dbm_clearerr(db); - dbm_close(db); - if (dbm_error(db)) { - fprintf(stderr, "Error closing database \"%s\"\n", comarg[0]); - exit(-1); - } + dbm_clearerr(db); + dbm_close(db); + if (dbm_error(db)) { + fprintf(stderr, "Error closing database \"%s\"\n", comarg[0]); + exit(-1); + } } diff --git a/ext/SDBM_File/dbu.c b/ext/SDBM_File/dbu.c index ef1963d350..9cf48fa397 100644 --- a/ext/SDBM_File/dbu.c +++ b/ext/SDBM_File/dbu.c @@ -28,30 +28,30 @@ static char *usage = "%s [-R] cat | look |... dbmname"; #define LINEMAX 8192 typedef struct { - char *sname; - int scode; - int flags; + char *sname; + int scode; + int flags; } cmd; static cmd cmds[] = { - "fetch", DLOOK, O_RDONLY, - "get", DLOOK, O_RDONLY, - "look", DLOOK, O_RDONLY, - "add", DINSERT, O_RDWR, - "insert", DINSERT, O_RDWR, - "store", DINSERT, O_RDWR, - "delete", DDELETE, O_RDWR, - "remove", DDELETE, O_RDWR, - "dump", DCAT, O_RDONLY, - "list", DCAT, O_RDONLY, - "cat", DCAT, O_RDONLY, - "creat", DCREAT, O_RDWR | O_CREAT | O_TRUNC, - "new", DCREAT, O_RDWR | O_CREAT | O_TRUNC, - "build", DBUILD, O_RDWR | O_CREAT, - "squash", DPRESS, O_RDWR, - "compact", DPRESS, O_RDWR, - "compress", DPRESS, O_RDWR + "fetch", DLOOK, O_RDONLY, + "get", DLOOK, O_RDONLY, + "look", DLOOK, O_RDONLY, + "add", DINSERT, O_RDWR, + "insert", DINSERT, O_RDWR, + "store", DINSERT, O_RDWR, + "delete", DDELETE, O_RDWR, + "remove", DDELETE, O_RDWR, + "dump", DCAT, O_RDONLY, + "list", DCAT, O_RDONLY, + "cat", DCAT, O_RDONLY, + "creat", DCREAT, O_RDWR | O_CREAT | O_TRUNC, + "new", DCREAT, O_RDWR | O_CREAT | O_TRUNC, + "build", DBUILD, O_RDWR | O_CREAT, + "squash", DPRESS, O_RDWR, + "compact", DPRESS, O_RDWR, + "compress", DPRESS, O_RDWR }; #define CTABSIZ (sizeof (cmds)/sizeof (cmd)) @@ -62,173 +62,173 @@ static void badk(), doit(), prdatum(); int main(int argc, char **argv) { - int c; - cmd *act; - extern int optind; - extern char *optarg; - - progname = argv[0]; - - while ((c = getopt(argc, argv, "R")) != EOF) - switch (c) { - case 'R': /* raw processing */ - rflag++; - break; - - default: - oops("usage: %s", usage); - break; - } - - if ((argc -= optind) < 2) - oops("usage: %s", usage); - - if ((act = parse(argv[optind])) == NULL) - badk(argv[optind]); - optind++; - doit(act, argv[optind]); - return 0; + int c; + cmd *act; + extern int optind; + extern char *optarg; + + progname = argv[0]; + + while ((c = getopt(argc, argv, "R")) != EOF) + switch (c) { + case 'R': /* raw processing */ + rflag++; + break; + + default: + oops("usage: %s", usage); + break; + } + + if ((argc -= optind) < 2) + oops("usage: %s", usage); + + if ((act = parse(argv[optind])) == NULL) + badk(argv[optind]); + optind++; + doit(act, argv[optind]); + return 0; } static void doit(cmd *act, char *file) { - datum key; - datum val; - DBM *db; - char *op; - int n; - char *line; + datum key; + datum val; + DBM *db; + char *op; + int n; + char *line; #ifdef TIME - long start; - extern long time(); + long start; + extern long time(); #endif - if ((db = dbm_open(file, act->flags, 0644)) == NULL) - oops("cannot open: %s", file); - - if ((line = (char *) malloc(LINEMAX)) == NULL) - oops("%s: cannot get memory", "line alloc"); - - switch (act->scode) { - - case DLOOK: - while (fgets(line, LINEMAX, stdin) != NULL) { - n = strlen(line) - 1; - line[n] = 0; - key.dptr = line; - key.dsize = n; - val = dbm_fetch(db, key); - if (val.dptr != NULL) { - prdatum(stdout, val); - putchar('\n'); - continue; - } - prdatum(stderr, key); - fprintf(stderr, ": not found.\n"); - } - break; - case DINSERT: - break; - case DDELETE: - while (fgets(line, LINEMAX, stdin) != NULL) { - n = strlen(line) - 1; - line[n] = 0; - key.dptr = line; - key.dsize = n; - if (dbm_delete(db, key) == -1) { - prdatum(stderr, key); - fprintf(stderr, ": not found.\n"); - } - } - break; - case DCAT: - for (key = dbm_firstkey(db); key.dptr != 0; - key = dbm_nextkey(db)) { - prdatum(stdout, key); - putchar('\t'); - prdatum(stdout, dbm_fetch(db, key)); - putchar('\n'); - } - break; - case DBUILD: + if ((db = dbm_open(file, act->flags, 0644)) == NULL) + oops("cannot open: %s", file); + + if ((line = (char *) malloc(LINEMAX)) == NULL) + oops("%s: cannot get memory", "line alloc"); + + switch (act->scode) { + + case DLOOK: + while (fgets(line, LINEMAX, stdin) != NULL) { + n = strlen(line) - 1; + line[n] = 0; + key.dptr = line; + key.dsize = n; + val = dbm_fetch(db, key); + if (val.dptr != NULL) { + prdatum(stdout, val); + putchar('\n'); + continue; + } + prdatum(stderr, key); + fprintf(stderr, ": not found.\n"); + } + break; + case DINSERT: + break; + case DDELETE: + while (fgets(line, LINEMAX, stdin) != NULL) { + n = strlen(line) - 1; + line[n] = 0; + key.dptr = line; + key.dsize = n; + if (dbm_delete(db, key) == -1) { + prdatum(stderr, key); + fprintf(stderr, ": not found.\n"); + } + } + break; + case DCAT: + for (key = dbm_firstkey(db); key.dptr != 0; + key = dbm_nextkey(db)) { + prdatum(stdout, key); + putchar('\t'); + prdatum(stdout, dbm_fetch(db, key)); + putchar('\n'); + } + break; + case DBUILD: #ifdef TIME - start = time(0); + start = time(0); #endif - while (fgets(line, LINEMAX, stdin) != NULL) { - n = strlen(line) - 1; - line[n] = 0; - key.dptr = line; - if ((op = strchr(line, '\t')) != 0) { - key.dsize = op - line; - *op++ = 0; - val.dptr = op; - val.dsize = line + n - op; - } - else - oops("bad input; %s", line); - - if (dbm_store(db, key, val, DBM_REPLACE) < 0) { - prdatum(stderr, key); - fprintf(stderr, ": "); - oops("store: %s", "failed"); - } - } + while (fgets(line, LINEMAX, stdin) != NULL) { + n = strlen(line) - 1; + line[n] = 0; + key.dptr = line; + if ((op = strchr(line, '\t')) != 0) { + key.dsize = op - line; + *op++ = 0; + val.dptr = op; + val.dsize = line + n - op; + } + else + oops("bad input; %s", line); + + if (dbm_store(db, key, val, DBM_REPLACE) < 0) { + prdatum(stderr, key); + fprintf(stderr, ": "); + oops("store: %s", "failed"); + } + } #ifdef TIME - printf("done: %d seconds.\n", time(0) - start); + printf("done: %d seconds.\n", time(0) - start); #endif - break; - case DPRESS: - break; - case DCREAT: - break; - } - - dbm_close(db); + break; + case DPRESS: + break; + case DCREAT: + break; + } + + dbm_close(db); } static void badk(char *word) { - int i; - - if (progname) - fprintf(stderr, "%s: ", progname); - fprintf(stderr, "bad keywd %s. use one of\n", word); - for (i = 0; i < (int)CTABSIZ; i++) - fprintf(stderr, "%-8s%c", cmds[i].sname, - ((i + 1) % 6 == 0) ? '\n' : ' '); - fprintf(stderr, "\n"); - exit(1); - /*NOTREACHED*/ + int i; + + if (progname) + fprintf(stderr, "%s: ", progname); + fprintf(stderr, "bad keywd %s. use one of\n", word); + for (i = 0; i < (int)CTABSIZ; i++) + fprintf(stderr, "%-8s%c", cmds[i].sname, + ((i + 1) % 6 == 0) ? '\n' : ' '); + fprintf(stderr, "\n"); + exit(1); + /*NOTREACHED*/ } static cmd * parse(char *str) { - int i = CTABSIZ; - cmd *p; - - for (p = cmds; i--; p++) - if (strcmp(p->sname, str) == 0) - return p; - return NULL; + int i = CTABSIZ; + cmd *p; + + for (p = cmds; i--; p++) + if (strcmp(p->sname, str) == 0) + return p; + return NULL; } static void prdatum(FILE *stream, datum d) { - int c; - U8 *p = (U8 *) d.dptr; - int n = d.dsize; + int c; + U8 *p = (U8 *) d.dptr; + int n = d.dsize; - while (n--) { - c = *p++; + while (n--) { + c = *p++; #ifndef EBCDIC /* Meta notation doesn't make sense on EBCDIC systems*/ - if (c & 0200) { + if (c & 0200) { fprintf(stream, "M-"); c &= 0177; - } + } #endif /* \c notation applies for \0 . \x1f, plus \c? */ if (c <= 0x1F || c == QUESTION_MARK_CTRL) { @@ -237,12 +237,12 @@ prdatum(FILE *stream, datum d) #ifdef EBCDIC /* Instead of meta, use \x{} for non-printables */ else if (! isPRINT_A(c)) { fprintf(stream, "\\x{%02x}", c); - } + } #endif - else { /* must be an ASCII printable */ + else { /* must be an ASCII printable */ putc(c, stream); } - } + } } diff --git a/ext/SDBM_File/sdbm.c b/ext/SDBM_File/sdbm.c index d7839aa8c2..b81d1e30c1 100644 --- a/ext/SDBM_File/sdbm.c +++ b/ext/SDBM_File/sdbm.c @@ -29,7 +29,7 @@ */ #include <errno.h> /* See notes in perl.h about avoiding - extern int errno; */ + extern int errno; */ #ifdef __cplusplus extern "C" { #endif @@ -63,58 +63,58 @@ static int makroom(DBM *, long, int); #define OFF_DIR(off) (long) (off) * DBLKSIZ static const long masks[] = { - 000000000000, 000000000001, 000000000003, 000000000007, - 000000000017, 000000000037, 000000000077, 000000000177, - 000000000377, 000000000777, 000000001777, 000000003777, - 000000007777, 000000017777, 000000037777, 000000077777, - 000000177777, 000000377777, 000000777777, 000001777777, - 000003777777, 000007777777, 000017777777, 000037777777, - 000077777777, 000177777777, 000377777777, 000777777777, - 001777777777, 003777777777, 007777777777, 017777777777 + 000000000000, 000000000001, 000000000003, 000000000007, + 000000000017, 000000000037, 000000000077, 000000000177, + 000000000377, 000000000777, 000000001777, 000000003777, + 000000007777, 000000017777, 000000037777, 000000077777, + 000000177777, 000000377777, 000000777777, 000001777777, + 000003777777, 000007777777, 000017777777, 000037777777, + 000077777777, 000177777777, 000377777777, 000777777777, + 001777777777, 003777777777, 007777777777, 017777777777 }; DBM * sdbm_open(char *file, int flags, int mode) { - DBM *db; - char *dirname; - char *pagname; - size_t filelen; - const size_t dirfext_size = sizeof(DIRFEXT ""); - const size_t pagfext_size = sizeof(PAGFEXT ""); - - if (file == NULL || !*file) - return errno = EINVAL, (DBM *) NULL; + DBM *db; + char *dirname; + char *pagname; + size_t filelen; + const size_t dirfext_size = sizeof(DIRFEXT ""); + const size_t pagfext_size = sizeof(PAGFEXT ""); + + if (file == NULL || !*file) + return errno = EINVAL, (DBM *) NULL; /* * need space for two separate filenames */ - filelen = strlen(file); + filelen = strlen(file); - if ((dirname = (char *) malloc(filelen + dirfext_size - + filelen + pagfext_size)) == NULL) - return errno = ENOMEM, (DBM *) NULL; + if ((dirname = (char *) malloc(filelen + dirfext_size + + filelen + pagfext_size)) == NULL) + return errno = ENOMEM, (DBM *) NULL; /* * build the file names */ - memcpy(dirname, file, filelen); - memcpy(dirname + filelen, DIRFEXT, dirfext_size); - pagname = dirname + filelen + dirfext_size; - memcpy(pagname, file, filelen); - memcpy(pagname + filelen, PAGFEXT, pagfext_size); - - db = sdbm_prep(dirname, pagname, flags, mode); - free((char *) dirname); - return db; + memcpy(dirname, file, filelen); + memcpy(dirname + filelen, DIRFEXT, dirfext_size); + pagname = dirname + filelen + dirfext_size; + memcpy(pagname, file, filelen); + memcpy(pagname + filelen, PAGFEXT, pagfext_size); + + db = sdbm_prep(dirname, pagname, flags, mode); + free((char *) dirname); + return db; } DBM * sdbm_prep(char *dirname, char *pagname, int flags, int mode) { - DBM *db; - struct stat dstat; + DBM *db; + struct stat dstat; - if ((db = (DBM *) malloc(sizeof(DBM))) == NULL) - return errno = ENOMEM, (DBM *) NULL; + if ((db = (DBM *) malloc(sizeof(DBM))) == NULL) + return errno = ENOMEM, (DBM *) NULL; db->flags = 0; db->hmask = 0; @@ -125,158 +125,158 @@ sdbm_prep(char *dirname, char *pagname, int flags, int mode) * as required by this package. Also set our internal * flag for RDONLY if needed. */ - if (flags & O_WRONLY) - flags = (flags & ~O_WRONLY) | O_RDWR; + if (flags & O_WRONLY) + flags = (flags & ~O_WRONLY) | O_RDWR; - else if ((flags & 03) == O_RDONLY) - db->flags = DBM_RDONLY; + else if ((flags & 03) == O_RDONLY) + db->flags = DBM_RDONLY; /* * open the files in sequence, and stat the dirfile. * If we fail anywhere, undo everything, return NULL. */ #if defined(OS2) || defined(MSDOS) || defined(WIN32) || defined(__CYGWIN__) - flags |= O_BINARY; + flags |= O_BINARY; # endif - if ((db->pagf = open(pagname, flags, mode)) > -1) { - if ((db->dirf = open(dirname, flags, mode)) > -1) { + if ((db->pagf = open(pagname, flags, mode)) > -1) { + if ((db->dirf = open(dirname, flags, mode)) > -1) { /* * need the dirfile size to establish max bit number. */ - if (fstat(db->dirf, &dstat) == 0) { + if (fstat(db->dirf, &dstat) == 0) { /* * zero size: either a fresh database, or one with a single, * unsplit data page: dirpage is all zeros. */ - db->dirbno = (!dstat.st_size) ? 0 : -1; - db->pagbno = -1; - db->maxbno = dstat.st_size * BYTESIZ; - - (void) memset(db->pagbuf, 0, PBLKSIZ); - (void) memset(db->dirbuf, 0, DBLKSIZ); - /* - * success - */ - return db; - } - (void) close(db->dirf); - } - (void) close(db->pagf); - } - free((char *) db); - return (DBM *) NULL; + db->dirbno = (!dstat.st_size) ? 0 : -1; + db->pagbno = -1; + db->maxbno = dstat.st_size * BYTESIZ; + + (void) memset(db->pagbuf, 0, PBLKSIZ); + (void) memset(db->dirbuf, 0, DBLKSIZ); + /* + * success + */ + return db; + } + (void) close(db->dirf); + } + (void) close(db->pagf); + } + free((char *) db); + return (DBM *) NULL; } void sdbm_close(DBM *db) { - if (db == NULL) - errno = EINVAL; - else { - (void) close(db->dirf); - (void) close(db->pagf); - free((char *) db); - } + if (db == NULL) + errno = EINVAL; + else { + (void) close(db->dirf); + (void) close(db->pagf); + free((char *) db); + } } datum sdbm_fetch(DBM *db, datum key) { - if (db == NULL || bad(key)) - return errno = EINVAL, nullitem; + if (db == NULL || bad(key)) + return errno = EINVAL, nullitem; - if (getpage(db, exhash(key))) - return getpair(db->pagbuf, key); + if (getpage(db, exhash(key))) + return getpair(db->pagbuf, key); - return ioerr(db), nullitem; + return ioerr(db), nullitem; } int sdbm_exists(DBM *db, datum key) { - if (db == NULL || bad(key)) - return errno = EINVAL, -1; + if (db == NULL || bad(key)) + return errno = EINVAL, -1; - if (getpage(db, exhash(key))) - return exipair(db->pagbuf, key); + if (getpage(db, exhash(key))) + return exipair(db->pagbuf, key); - return ioerr(db), -1; + return ioerr(db), -1; } int sdbm_delete(DBM *db, datum key) { - if (db == NULL || bad(key)) - return errno = EINVAL, -1; - if (sdbm_rdonly(db)) - return errno = EPERM, -1; - - if (getpage(db, exhash(key))) { - if (!delpair(db->pagbuf, key)) - return -1; + if (db == NULL || bad(key)) + return errno = EINVAL, -1; + if (sdbm_rdonly(db)) + return errno = EPERM, -1; + + if (getpage(db, exhash(key))) { + if (!delpair(db->pagbuf, key)) + return -1; /* * update the page file */ - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return ioerr(db), -1; + if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 + || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return ioerr(db), -1; - return 0; - } + return 0; + } - return ioerr(db), -1; + return ioerr(db), -1; } int sdbm_store(DBM *db, datum key, datum val, int flags) { - int need; - long hash; + int need; + long hash; - if (db == NULL || bad(key)) - return errno = EINVAL, -1; - if (sdbm_rdonly(db)) - return errno = EPERM, -1; + if (db == NULL || bad(key)) + return errno = EINVAL, -1; + if (sdbm_rdonly(db)) + return errno = EPERM, -1; - need = key.dsize + val.dsize; + need = key.dsize + val.dsize; /* * is the pair too big (or too small) for this database ?? */ - if (need < 0 || need > PAIRMAX) - return errno = EINVAL, -1; + if (need < 0 || need > PAIRMAX) + return errno = EINVAL, -1; - if (getpage(db, (hash = exhash(key)))) { + if (getpage(db, (hash = exhash(key)))) { /* * if we need to replace, delete the key/data pair * first. If it is not there, ignore. */ - if (flags == DBM_REPLACE) - (void) delpair(db->pagbuf, key); + if (flags == DBM_REPLACE) + (void) delpair(db->pagbuf, key); #ifdef SEEDUPS - else if (duppair(db->pagbuf, key)) - return 1; + else if (duppair(db->pagbuf, key)) + return 1; #endif /* * if we do not have enough room, we have to split. */ - if (!fitpair(db->pagbuf, need)) - if (!makroom(db, hash, need)) - return ioerr(db), -1; + if (!fitpair(db->pagbuf, need)) + if (!makroom(db, hash, need)) + return ioerr(db), -1; /* * we have enough room or split is successful. insert the key, * and update the page file. */ - (void) putpair(db->pagbuf, key, val); - - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return ioerr(db), -1; - /* - * success - */ - return 0; - } - - return ioerr(db), -1; + (void) putpair(db->pagbuf, key, val); + + if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 + || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return ioerr(db), -1; + /* + * success + */ + return 0; + } + + return ioerr(db), -1; } /* @@ -287,28 +287,28 @@ sdbm_store(DBM *db, datum key, datum val, int flags) static int makroom(DBM *db, long int hash, int need) { - long newp; - char twin[PBLKSIZ]; + long newp; + char twin[PBLKSIZ]; #if defined(DOSISH) || defined(WIN32) - char zer[PBLKSIZ]; - long oldtail; + char zer[PBLKSIZ]; + long oldtail; #endif - char *pag = db->pagbuf; - char *New = twin; - int smax = SPLTMAX; + char *pag = db->pagbuf; + char *New = twin; + int smax = SPLTMAX; #ifdef BADMESS - int rc; + int rc; #endif - do { + do { /* * split the current page */ - (void) splpage(pag, New, db->hmask + 1); + (void) splpage(pag, New, db->hmask + 1); /* * address of the new page */ - newp = (hash & db->hmask) | (db->hmask + 1); + newp = (hash & db->hmask) | (db->hmask + 1); /* * write delay, read avoidance/cache shuffle: @@ -320,65 +320,65 @@ makroom(DBM *db, long int hash, int need) */ #if defined(DOSISH) || defined(WIN32) - /* - * Fill hole with 0 if made it. - * (hole is NOT read as 0) - */ - oldtail = lseek(db->pagf, 0L, SEEK_END); - memset(zer, 0, PBLKSIZ); - while (OFF_PAG(newp) > oldtail) { - if (lseek(db->pagf, 0L, SEEK_END) < 0 || - write(db->pagf, zer, PBLKSIZ) < 0) { - - return 0; - } - oldtail += PBLKSIZ; - } + /* + * Fill hole with 0 if made it. + * (hole is NOT read as 0) + */ + oldtail = lseek(db->pagf, 0L, SEEK_END); + memset(zer, 0, PBLKSIZ); + while (OFF_PAG(newp) > oldtail) { + if (lseek(db->pagf, 0L, SEEK_END) < 0 || + write(db->pagf, zer, PBLKSIZ) < 0) { + + return 0; + } + oldtail += PBLKSIZ; + } #endif - if (hash & (db->hmask + 1)) { - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return 0; - db->pagbno = newp; - (void) memcpy(pag, New, PBLKSIZ); - } - else if (lseek(db->pagf, OFF_PAG(newp), SEEK_SET) < 0 - || write(db->pagf, New, PBLKSIZ) < 0) - return 0; - - if (!setdbit(db, db->curbit)) - return 0; + if (hash & (db->hmask + 1)) { + if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 + || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return 0; + db->pagbno = newp; + (void) memcpy(pag, New, PBLKSIZ); + } + else if (lseek(db->pagf, OFF_PAG(newp), SEEK_SET) < 0 + || write(db->pagf, New, PBLKSIZ) < 0) + return 0; + + if (!setdbit(db, db->curbit)) + return 0; /* * see if we have enough room now */ - if (fitpair(pag, need)) - return 1; + if (fitpair(pag, need)) + return 1; /* * try again... update curbit and hmask as getpage would have * done. because of our update of the current page, we do not * need to read in anything. BUT we have to write the current * [deferred] page out, as the window of failure is too great. */ - db->curbit = 2 * db->curbit + - ((hash & (db->hmask + 1)) ? 2 : 1); - db->hmask |= db->hmask + 1; + db->curbit = 2 * db->curbit + + ((hash & (db->hmask + 1)) ? 2 : 1); + db->hmask |= db->hmask + 1; - if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 - || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return 0; + if (lseek(db->pagf, OFF_PAG(db->pagbno), SEEK_SET) < 0 + || write(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return 0; - } while (--smax); + } while (--smax); /* * if we are here, this is real bad news. After SPLTMAX splits, * we still cannot fit the key. say goodnight. */ #ifdef BADMESS - rc = write(2, "sdbm: cannot insert after SPLTMAX attempts.\n", 44); - /* PERL_UNUSED_VAR() or PERL_UNUSED_RESULT() would be - * useful here but that would mean pulling in perl.h */ - (void)rc; + rc = write(2, "sdbm: cannot insert after SPLTMAX attempts.\n", 44); + /* PERL_UNUSED_VAR() or PERL_UNUSED_RESULT() would be + * useful here but that would mean pulling in perl.h */ + (void)rc; #endif - return 0; + return 0; } @@ -389,33 +389,33 @@ makroom(DBM *db, long int hash, int need) datum sdbm_firstkey(DBM *db) { - if (db == NULL) - return errno = EINVAL, nullitem; + if (db == NULL) + return errno = EINVAL, nullitem; /* * start at page 0 */ - if (lseek(db->pagf, OFF_PAG(0), SEEK_SET) < 0 - || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return ioerr(db), nullitem; + if (lseek(db->pagf, OFF_PAG(0), SEEK_SET) < 0 + || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return ioerr(db), nullitem; if (!chkpage(db->pagbuf)) { errno = EINVAL; ioerr(db); db->pagbno = -1; return nullitem; } - db->pagbno = 0; - db->blkptr = 0; - db->keyptr = 0; + db->pagbno = 0; + db->blkptr = 0; + db->keyptr = 0; - return getnext(db); + return getnext(db); } datum sdbm_nextkey(DBM *db) { - if (db == NULL) - return errno = EINVAL, nullitem; - return getnext(db); + if (db == NULL) + return errno = EINVAL, nullitem; + return getnext(db); } /* @@ -424,106 +424,106 @@ sdbm_nextkey(DBM *db) static int getpage(DBM *db, long int hash) { - int hbit; - long dbit; - long pagb; + int hbit; + long dbit; + long pagb; - dbit = 0; - hbit = 0; - while (dbit < db->maxbno && getdbit(db, dbit)) - dbit = 2 * dbit + ((hash & (1 << hbit++)) ? 2 : 1); + dbit = 0; + hbit = 0; + while (dbit < db->maxbno && getdbit(db, dbit)) + dbit = 2 * dbit + ((hash & (1 << hbit++)) ? 2 : 1); - debug(("dbit: %d...", dbit)); + debug(("dbit: %d...", dbit)); - db->curbit = dbit; - db->hmask = masks[hbit]; + db->curbit = dbit; + db->hmask = masks[hbit]; - pagb = hash & db->hmask; + pagb = hash & db->hmask; /* * see if the block we need is already in memory. * note: this lookaside cache has about 10% hit rate. */ - if (pagb != db->pagbno) { + if (pagb != db->pagbno) { /* * note: here, we assume a "hole" is read as 0s. * if not, must zero pagbuf first. */ - if (lseek(db->pagf, OFF_PAG(pagb), SEEK_SET) < 0 - || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) - return 0; - if (!chkpage(db->pagbuf)) { + if (lseek(db->pagf, OFF_PAG(pagb), SEEK_SET) < 0 + || read(db->pagf, db->pagbuf, PBLKSIZ) < 0) + return 0; + if (!chkpage(db->pagbuf)) { errno = EINVAL; db->pagbno = -1; ioerr(db); return 0; } - db->pagbno = pagb; + db->pagbno = pagb; - debug(("pag read: %d\n", pagb)); - } - return 1; + debug(("pag read: %d\n", pagb)); + } + return 1; } static int getdbit(DBM *db, long int dbit) { - long c; - long dirb; - - c = dbit / BYTESIZ; - dirb = c / DBLKSIZ; - - if (dirb != db->dirbno) { - int got; - if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) - return 0; - if (got==0) - memset(db->dirbuf,0,DBLKSIZ); - db->dirbno = dirb; - - debug(("dir read: %d\n", dirb)); - } + long c; + long dirb; + + c = dbit / BYTESIZ; + dirb = c / DBLKSIZ; + + if (dirb != db->dirbno) { + int got; + if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 + || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) + return 0; + if (got==0) + memset(db->dirbuf,0,DBLKSIZ); + db->dirbno = dirb; + + debug(("dir read: %d\n", dirb)); + } - return db->dirbuf[c % DBLKSIZ] & (1 << dbit % BYTESIZ); + return db->dirbuf[c % DBLKSIZ] & (1 << dbit % BYTESIZ); } static int setdbit(DBM *db, long int dbit) { - long c; - long dirb; - - c = dbit / BYTESIZ; - dirb = c / DBLKSIZ; - - if (dirb != db->dirbno) { - int got; - if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) - return 0; - if (got==0) - memset(db->dirbuf,0,DBLKSIZ); - db->dirbno = dirb; - - debug(("dir read: %d\n", dirb)); - } + long c; + long dirb; + + c = dbit / BYTESIZ; + dirb = c / DBLKSIZ; + + if (dirb != db->dirbno) { + int got; + if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 + || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) + return 0; + if (got==0) + memset(db->dirbuf,0,DBLKSIZ); + db->dirbno = dirb; + + debug(("dir read: %d\n", dirb)); + } - db->dirbuf[c % DBLKSIZ] |= (1 << dbit % BYTESIZ); + db->dirbuf[c % DBLKSIZ] |= (1 << dbit % BYTESIZ); #if 0 - if (dbit >= db->maxbno) - db->maxbno += DBLKSIZ * BYTESIZ; + if (dbit >= db->maxbno) + db->maxbno += DBLKSIZ * BYTESIZ; #else - if (OFF_DIR((dirb+1))*BYTESIZ > db->maxbno) - db->maxbno=OFF_DIR((dirb+1))*BYTESIZ; + if (OFF_DIR((dirb+1))*BYTESIZ > db->maxbno) + db->maxbno=OFF_DIR((dirb+1))*BYTESIZ; #endif - if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || write(db->dirf, db->dirbuf, DBLKSIZ) < 0) - return 0; + if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 + || write(db->dirf, db->dirbuf, DBLKSIZ) < 0) + return 0; - return 1; + return 1; } /* @@ -533,33 +533,33 @@ setdbit(DBM *db, long int dbit) static datum getnext(DBM *db) { - datum key; + datum key; - for (;;) { - db->keyptr++; - key = getnkey(db->pagbuf, db->keyptr); - if (key.dptr != NULL) - return key; + for (;;) { + db->keyptr++; + key = getnkey(db->pagbuf, db->keyptr); + if (key.dptr != NULL) + return key; /* * we either run out, or there is nothing on this page.. * try the next one... If we lost our position on the * file, we will have to seek. */ - db->keyptr = 0; - if (db->pagbno != db->blkptr++) - if (lseek(db->pagf, OFF_PAG(db->blkptr), SEEK_SET) < 0) - break; - db->pagbno = db->blkptr; - if (read(db->pagf, db->pagbuf, PBLKSIZ) <= 0) - break; - if (!chkpage(db->pagbuf)) { + db->keyptr = 0; + if (db->pagbno != db->blkptr++) + if (lseek(db->pagf, OFF_PAG(db->blkptr), SEEK_SET) < 0) + break; + db->pagbno = db->blkptr; + if (read(db->pagf, db->pagbuf, PBLKSIZ) <= 0) + break; + if (!chkpage(db->pagbuf)) { errno = EINVAL; db->pagbno = -1; ioerr(db); break; } - } + } - return ioerr(db), nullitem; + return ioerr(db), nullitem; } diff --git a/ext/SDBM_File/sdbm.h b/ext/SDBM_File/sdbm.h index 428303d307..199a2eec0c 100644 --- a/ext/SDBM_File/sdbm.h +++ b/ext/SDBM_File/sdbm.h @@ -11,7 +11,7 @@ #define PBLKSIZ 1024 #define PAIRMAX 1008 /* arbitrary on PBLKSIZ-N */ #define SPLTMAX 10 /* maximum allowed splits */ - /* for a single insertion */ + /* for a single insertion */ #ifdef VMS #define DIRFEXT ".sdbm_dir" #else @@ -20,19 +20,19 @@ #define PAGFEXT ".pag" typedef struct { - int dirf; /* directory file descriptor */ - int pagf; /* page file descriptor */ - int flags; /* status/error flags, see below */ - long maxbno; /* size of dirfile in bits */ - long curbit; /* current bit number */ - long hmask; /* current hash mask */ - long blkptr; /* current block for nextkey */ - int keyptr; /* current key for nextkey */ - long blkno; /* current page to read/write */ - long pagbno; /* current page in pagbuf */ - char pagbuf[PBLKSIZ]; /* page file block buffer */ - long dirbno; /* current block in dirbuf */ - char dirbuf[DBLKSIZ]; /* directory file block buffer */ + int dirf; /* directory file descriptor */ + int pagf; /* page file descriptor */ + int flags; /* status/error flags, see below */ + long maxbno; /* size of dirfile in bits */ + long curbit; /* current bit number */ + long hmask; /* current hash mask */ + long blkptr; /* current block for nextkey */ + int keyptr; /* current key for nextkey */ + long blkno; /* current page to read/write */ + long pagbno; /* current page in pagbuf */ + char pagbuf[PBLKSIZ]; /* page file block buffer */ + long dirbno; /* current block in dirbuf */ + char dirbuf[DBLKSIZ]; /* directory file block buffer */ } DBM; #define DBM_RDONLY 0x1 /* data base open read-only */ @@ -50,8 +50,8 @@ typedef struct { #define sdbm_pagfno(db) ((db)->pagf) typedef struct { - const char *dptr; - int dsize; + const char *dptr; + int dsize; } datum; extern const datum nullitem; diff --git a/ext/SDBM_File/tune.h b/ext/SDBM_File/tune.h index b95c8c8634..c4b36a0580 100644 --- a/ext/SDBM_File/tune.h +++ b/ext/SDBM_File/tune.h @@ -12,7 +12,7 @@ #define SEEDUPS /* always detect duplicates */ #define BADMESS /* generate a message for worst case: - cannot make room after SPLTMAX splits */ + cannot make room after SPLTMAX splits */ /* * misc */ diff --git a/ext/SDBM_File/util.c b/ext/SDBM_File/util.c index a58085d559..0fa93ef341 100644 --- a/ext/SDBM_File/util.c +++ b/ext/SDBM_File/util.c @@ -8,40 +8,40 @@ void oops(char *s1, char *s2) { - extern int errno, sys_nerr; - extern char *sys_errlist[]; - extern char *progname; + extern int errno, sys_nerr; + extern char *sys_errlist[]; + extern char *progname; - if (progname) - fprintf(stderr, "%s: ", progname); - fprintf(stderr, s1, s2); - if (errno > 0 && errno < sys_nerr) - fprintf(stderr, " (%s)", sys_errlist[errno]); - fprintf(stderr, "\n"); - exit(1); + if (progname) + fprintf(stderr, "%s: ", progname); + fprintf(stderr, s1, s2); + if (errno > 0 && errno < sys_nerr) + fprintf(stderr, " (%s)", sys_errlist[errno]); + fprintf(stderr, "\n"); + exit(1); } int okpage(char *pag) { - unsigned n; - int off; - short *ino = (short *) pag; + unsigned n; + int off; + short *ino = (short *) pag; - if ((n = ino[0]) > PBLKSIZ / sizeof(short)) - return 0; + if ((n = ino[0]) > PBLKSIZ / sizeof(short)) + return 0; - if (!n) - return 1; + if (!n) + return 1; - off = PBLKSIZ; - for (ino++; n; ino += 2) { - if (ino[0] > off || ino[1] > off || - ino[1] > ino[0]) - return 0; - off = ino[1]; - n -= 2; - } + off = PBLKSIZ; + for (ino++; n; ino += 2) { + if (ino[0] > off || ino[1] > off || + ino[1] > ino[0]) + return 0; + off = ino[1]; + n -= 2; + } - return 1; + return 1; } diff --git a/ext/Win32CORE/Win32CORE.c b/ext/Win32CORE/Win32CORE.c index 6e5e1cec01..6784e460fe 100644 --- a/ext/Win32CORE/Win32CORE.c +++ b/ext/Win32CORE/Win32CORE.c @@ -64,78 +64,78 @@ init_Win32CORE(pTHX) */ static const struct { - char Win32__GetCwd [sizeof("Win32::GetCwd")]; - char Win32__SetCwd [sizeof("Win32::SetCwd")]; - char Win32__GetNextAvailDrive [sizeof("Win32::GetNextAvailDrive")]; - char Win32__GetLastError [sizeof("Win32::GetLastError")]; - char Win32__SetLastError [sizeof("Win32::SetLastError")]; - char Win32__LoginName [sizeof("Win32::LoginName")]; - char Win32__NodeName [sizeof("Win32::NodeName")]; - char Win32__DomainName [sizeof("Win32::DomainName")]; - char Win32__FsType [sizeof("Win32::FsType")]; - char Win32__GetOSVersion [sizeof("Win32::GetOSVersion")]; - char Win32__IsWinNT [sizeof("Win32::IsWinNT")]; - char Win32__IsWin95 [sizeof("Win32::IsWin95")]; - char Win32__FormatMessage [sizeof("Win32::FormatMessage")]; - char Win32__Spawn [sizeof("Win32::Spawn")]; - char Win32__GetTickCount [sizeof("Win32::GetTickCount")]; - char Win32__GetShortPathName [sizeof("Win32::GetShortPathName")]; - char Win32__GetFullPathName [sizeof("Win32::GetFullPathName")]; - char Win32__GetLongPathName [sizeof("Win32::GetLongPathName")]; - char Win32__CopyFile [sizeof("Win32::CopyFile")]; - char Win32__Sleep [sizeof("Win32::Sleep")]; + char Win32__GetCwd [sizeof("Win32::GetCwd")]; + char Win32__SetCwd [sizeof("Win32::SetCwd")]; + char Win32__GetNextAvailDrive [sizeof("Win32::GetNextAvailDrive")]; + char Win32__GetLastError [sizeof("Win32::GetLastError")]; + char Win32__SetLastError [sizeof("Win32::SetLastError")]; + char Win32__LoginName [sizeof("Win32::LoginName")]; + char Win32__NodeName [sizeof("Win32::NodeName")]; + char Win32__DomainName [sizeof("Win32::DomainName")]; + char Win32__FsType [sizeof("Win32::FsType")]; + char Win32__GetOSVersion [sizeof("Win32::GetOSVersion")]; + char Win32__IsWinNT [sizeof("Win32::IsWinNT")]; + char Win32__IsWin95 [sizeof("Win32::IsWin95")]; + char Win32__FormatMessage [sizeof("Win32::FormatMessage")]; + char Win32__Spawn [sizeof("Win32::Spawn")]; + char Win32__GetTickCount [sizeof("Win32::GetTickCount")]; + char Win32__GetShortPathName [sizeof("Win32::GetShortPathName")]; + char Win32__GetFullPathName [sizeof("Win32::GetFullPathName")]; + char Win32__GetLongPathName [sizeof("Win32::GetLongPathName")]; + char Win32__CopyFile [sizeof("Win32::CopyFile")]; + char Win32__Sleep [sizeof("Win32::Sleep")]; } fnname_table = { - "Win32::GetCwd", - "Win32::SetCwd", - "Win32::GetNextAvailDrive", - "Win32::GetLastError", - "Win32::SetLastError", - "Win32::LoginName", - "Win32::NodeName", - "Win32::DomainName", - "Win32::FsType", - "Win32::GetOSVersion", - "Win32::IsWinNT", - "Win32::IsWin95", - "Win32::FormatMessage", - "Win32::Spawn", - "Win32::GetTickCount", - "Win32::GetShortPathName", - "Win32::GetFullPathName", - "Win32::GetLongPathName", - "Win32::CopyFile", - "Win32::Sleep" + "Win32::GetCwd", + "Win32::SetCwd", + "Win32::GetNextAvailDrive", + "Win32::GetLastError", + "Win32::SetLastError", + "Win32::LoginName", + "Win32::NodeName", + "Win32::DomainName", + "Win32::FsType", + "Win32::GetOSVersion", + "Win32::IsWinNT", + "Win32::IsWin95", + "Win32::FormatMessage", + "Win32::Spawn", + "Win32::GetTickCount", + "Win32::GetShortPathName", + "Win32::GetFullPathName", + "Win32::GetLongPathName", + "Win32::CopyFile", + "Win32::Sleep" }; static const unsigned char fnname_lens [] = { - sizeof("Win32::GetCwd"), - sizeof("Win32::SetCwd"), - sizeof("Win32::GetNextAvailDrive"), - sizeof("Win32::GetLastError"), - sizeof("Win32::SetLastError"), - sizeof("Win32::LoginName"), - sizeof("Win32::NodeName"), - sizeof("Win32::DomainName"), - sizeof("Win32::FsType"), - sizeof("Win32::GetOSVersion"), - sizeof("Win32::IsWinNT"), - sizeof("Win32::IsWin95"), - sizeof("Win32::FormatMessage"), - sizeof("Win32::Spawn"), - sizeof("Win32::GetTickCount"), - sizeof("Win32::GetShortPathName"), - sizeof("Win32::GetFullPathName"), - sizeof("Win32::GetLongPathName"), - sizeof("Win32::CopyFile"), - sizeof("Win32::Sleep") + sizeof("Win32::GetCwd"), + sizeof("Win32::SetCwd"), + sizeof("Win32::GetNextAvailDrive"), + sizeof("Win32::GetLastError"), + sizeof("Win32::SetLastError"), + sizeof("Win32::LoginName"), + sizeof("Win32::NodeName"), + sizeof("Win32::DomainName"), + sizeof("Win32::FsType"), + sizeof("Win32::GetOSVersion"), + sizeof("Win32::IsWinNT"), + sizeof("Win32::IsWin95"), + sizeof("Win32::FormatMessage"), + sizeof("Win32::Spawn"), + sizeof("Win32::GetTickCount"), + sizeof("Win32::GetShortPathName"), + sizeof("Win32::GetFullPathName"), + sizeof("Win32::GetLongPathName"), + sizeof("Win32::CopyFile"), + sizeof("Win32::Sleep") }; const unsigned char * len = (const unsigned char *)&fnname_lens; const char * function = (char *)&fnname_table; while (function < (char *)&fnname_table + sizeof(fnname_table)) { - const char * const file = __FILE__; - CV * const cv = newXS(function, w32_CORE_all, file); - XSANY.any_ptr = (void *)function; - function += *len++; + const char * const file = __FILE__; + CV * const cv = newXS(function, w32_CORE_all, file); + XSANY.any_ptr = (void *)function; + function += *len++; } diff --git a/generate_uudmap.c b/generate_uudmap.c index 5ab7d8197f..b5f84a7695 100644 --- a/generate_uudmap.c +++ b/generate_uudmap.c @@ -71,13 +71,13 @@ format_mg_data(FILE *out, const void *thing, size_t count) { while (1) { if (p->value) { - fprintf(out, " %s\n %s", p->comment, p->value); + fprintf(out, " %s\n %s", p->comment, p->value); } else { - fputs(" 0", out); + fputs(" 0", out); } ++p; if (!--count) - break; + break; fputs(",\n", out); } fputc('\n', out); @@ -94,7 +94,7 @@ format_char_block(FILE *out, const void *thing, size_t count) { if (count) { fputs(", ", out); if (!(count & 15)) { - fputs("\n ", out); + fputs("\n ", out); } } } @@ -103,15 +103,15 @@ format_char_block(FILE *out, const void *thing, size_t count) { static void output_to_file(const char *progname, const char *filename, - void (format_function)(FILE *out, const void *thing, size_t count), - const void *thing, size_t count, + void (format_function)(FILE *out, const void *thing, size_t count), + const void *thing, size_t count, const char *header ) { FILE *const out = fopen(filename, "w"); if (!out) { fprintf(stderr, "%s: Could not open '%s': %s\n", progname, filename, - strerror(errno)); + strerror(errno)); exit(1); } @@ -124,7 +124,7 @@ output_to_file(const char *progname, const char *filename, if (fclose(out)) { fprintf(stderr, "%s: Could not close '%s': %s\n", progname, filename, - strerror(errno)); + strerror(errno)); exit(1); } } @@ -159,7 +159,7 @@ int main(int argc, char **argv) { PL_uudmap[(U8)' '] = 0; output_to_file(argv[0], argv[1], &format_char_block, - (const void *)PL_uudmap, sizeof(PL_uudmap), + (const void *)PL_uudmap, sizeof(PL_uudmap), " * These values will populate PL_uumap[], as used by unpack('u')" ); @@ -175,7 +175,7 @@ int main(int argc, char **argv) { } output_to_file(argv[0], argv[2], &format_char_block, - (const void *)PL_bitcount, sizeof(PL_bitcount), + (const void *)PL_bitcount, sizeof(PL_bitcount), " * These values will populate PL_bitcount[]:\n" " * this is a count of bits for each U8 value 0..255" ); @@ -187,7 +187,7 @@ int main(int argc, char **argv) { } output_to_file(argv[0], argv[3], &format_mg_data, - (const void *)mg_data, sizeof(mg_data)/sizeof(mg_data[0]), + (const void *)mg_data, sizeof(mg_data)/sizeof(mg_data[0]), " * These values will populate PL_magic_data[]: this is an array of\n" " * per-magic U8 values containing an index into PL_magic_vtables[]\n" " * plus two flags:\n" @@ -55,39 +55,39 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type) && SvTYPE((const SV *)gv) != SVt_PVLV ) ) { - const char *what; - if (type == SVt_PVIO) { - /* - * if it walks like a dirhandle, then let's assume that - * this is a dirhandle. - */ - what = OP_IS_DIRHOP(PL_op->op_type) ? - "dirhandle" : "filehandle"; - } else if (type == SVt_PVHV) { - what = "hash"; - } else { - what = type == SVt_PVAV ? "array" : "scalar"; - } - /* diag_listed_as: Bad symbol for filehandle */ - Perl_croak(aTHX_ "Bad symbol for %s", what); + const char *what; + if (type == SVt_PVIO) { + /* + * if it walks like a dirhandle, then let's assume that + * this is a dirhandle. + */ + what = OP_IS_DIRHOP(PL_op->op_type) ? + "dirhandle" : "filehandle"; + } else if (type == SVt_PVHV) { + what = "hash"; + } else { + what = type == SVt_PVAV ? "array" : "scalar"; + } + /* diag_listed_as: Bad symbol for filehandle */ + Perl_croak(aTHX_ "Bad symbol for %s", what); } if (type == SVt_PVHV) { - where = (SV **)&GvHV(gv); + where = (SV **)&GvHV(gv); } else if (type == SVt_PVAV) { - where = (SV **)&GvAV(gv); + where = (SV **)&GvAV(gv); } else if (type == SVt_PVIO) { - where = (SV **)&GvIOp(gv); + where = (SV **)&GvIOp(gv); } else { - where = &GvSV(gv); + where = &GvSV(gv); } if (!*where) { - *where = newSV_type(type); - if (type == SVt_PVAV - && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA")) - sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); + *where = newSV_type(type); + if (type == SVt_PVAV + && memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA")) + sv_magic(*where, (SV *)gv, PERL_MAGIC_isa, NULL, 0); } return gv; } @@ -122,7 +122,7 @@ Perl_gv_fetchfile(pTHX_ const char *name) GV * Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, - const U32 flags) + const U32 flags) { char smallbuf[128]; char *tmpbuf; @@ -133,29 +133,29 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, PERL_UNUSED_ARG(flags); if (!PL_defstash) - return NULL; + return NULL; if (tmplen <= sizeof smallbuf) - tmpbuf = smallbuf; + tmpbuf = smallbuf; else - Newx(tmpbuf, tmplen, char); + Newx(tmpbuf, tmplen, char); /* This is where the debugger's %{"::_<$filename"} hash is created */ tmpbuf[0] = '_'; tmpbuf[1] = '<'; memcpy(tmpbuf + 2, name, namelen); gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); if (!isGV(gv)) { - gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); + gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); #ifdef PERL_DONT_CREATE_GVSV - GvSV(gv) = newSVpvn(name, namelen); + GvSV(gv) = newSVpvn(name, namelen); #else - sv_setpvn(GvSV(gv), name, namelen); + sv_setpvn(GvSV(gv), name, namelen); #endif } if (PERLDB_LINE_OR_SAVESRC && !GvAV(gv)) - hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile); + hv_magic(GvHVn(gv), GvAVn(gv), PERL_MAGIC_dbfile); if (tmpbuf != smallbuf) - Safefree(tmpbuf); + Safefree(tmpbuf); return gv; } @@ -177,7 +177,7 @@ Perl_gv_const_sv(pTHX_ GV *gv) PERL_UNUSED_CONTEXT; if (SvTYPE(gv) == SVt_PVGV) - return cv_const_sv(GvCVu(gv)); + return cv_const_sv(GvCVu(gv)); return SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVAV && SvTYPE(SvRV(gv)) != SVt_PVCV ? SvRV(gv) : NULL; } @@ -200,29 +200,29 @@ Perl_newGP(pTHX_ GV *const gv) #endif /* PL_curcop may be null here. E.g., - INIT { bless {} and exit } + INIT { bless {} and exit } frees INIT before looking up DESTROY (and creating *DESTROY) */ if (PL_curcop) { - gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ + gp->gp_line = CopLINE(PL_curcop); /* 0 otherwise Newxz */ #ifdef USE_ITHREADS - if (CopFILE(PL_curcop)) { - file = CopFILE(PL_curcop); - len = strlen(file); - } + if (CopFILE(PL_curcop)) { + file = CopFILE(PL_curcop); + len = strlen(file); + } #else - filegv = CopFILEGV(PL_curcop); - if (filegv) { - file = GvNAME(filegv)+2; - len = GvNAMELEN(filegv)-2; - } + filegv = CopFILEGV(PL_curcop); + if (filegv) { + file = GvNAME(filegv)+2; + len = GvNAMELEN(filegv)-2; + } #endif - else goto no_file; + else goto no_file; } else { - no_file: - file = ""; - len = 0; + no_file: + file = ""; + len = 0; } PERL_HASH(hash, file, len); @@ -243,20 +243,20 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) PERL_ARGS_ASSERT_CVGV_SET; if (oldgv == gv) - return; + return; if (oldgv) { - if (CvCVGV_RC(cv)) { - SvREFCNT_dec_NN(oldgv); - CvCVGV_RC_off(cv); - } - else { - sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); - } + if (CvCVGV_RC(cv)) { + SvREFCNT_dec_NN(oldgv); + CvCVGV_RC_off(cv); + } + else { + sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); + } } else if ((hek = CvNAME_HEK(cv))) { - unshare_hek(hek); - CvLEXICAL_off(cv); + unshare_hek(hek); + CvLEXICAL_off(cv); } CvNAMED_off(cv); @@ -264,13 +264,13 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) assert(!CvCVGV_RC(cv)); if (!gv) - return; + return; if (isGV_with_GP(gv) && GvGP(gv) && (GvCV(gv) == cv || GvFORM(gv) == cv)) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv)); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(gv), MUTABLE_SV(cv)); else { - CvCVGV_RC_on(cv); - SvREFCNT_inc_simple_void_NN(gv); + CvCVGV_RC_on(cv); + SvREFCNT_inc_simple_void_NN(gv); } } @@ -290,12 +290,12 @@ Perl_cvgv_from_hek(pTHX_ CV *cv) svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0); gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0)); if (!isGV(gv)) - gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)), - HEK_LEN(CvNAME_HEK(cv)), - SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv))); + gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)), + HEK_LEN(CvNAME_HEK(cv)), + SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv))); if (!CvNAMED(cv)) { /* gv_init took care of it */ - assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv); - return gv; + assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv); + return gv; } unshare_hek(CvNAME_HEK(cv)); CvNAMED_off(cv); @@ -313,12 +313,12 @@ Perl_cvstash_set(pTHX_ CV *cv, HV *st) HV *oldst = CvSTASH(cv); PERL_ARGS_ASSERT_CVSTASH_SET; if (oldst == st) - return; + return; if (oldst) - sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv)); + sv_del_backref(MUTABLE_SV(oldst), MUTABLE_SV(cv)); SvANY(cv)->xcv_stash = st; if (st) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv)); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(st), MUTABLE_SV(cv)); } /* @@ -391,102 +391,102 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag const U32 old_type = SvTYPE(gv); const bool doproto = old_type > SVt_NULL; char * const proto = (doproto && SvPOK(gv)) - ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv)) - : NULL; + ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv)) + : NULL; const STRLEN protolen = proto ? SvCUR(gv) : 0; const U32 proto_utf8 = proto ? SvUTF8(gv) : 0; SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; const bool really_sub = - has_constant && SvTYPE(has_constant) == SVt_PVCV; + has_constant && SvTYPE(has_constant) == SVt_PVCV; COP * const old = PL_curcop; PERL_ARGS_ASSERT_GV_INIT_PVN; assert (!(proto && has_constant)); if (has_constant) { - /* The constant has to be a scalar, array or subroutine. */ - switch (SvTYPE(has_constant)) { - case SVt_PVHV: - case SVt_PVFM: - case SVt_PVIO: + /* The constant has to be a scalar, array or subroutine. */ + switch (SvTYPE(has_constant)) { + case SVt_PVHV: + case SVt_PVFM: + case SVt_PVIO: Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", - sv_reftype(has_constant, 0)); + sv_reftype(has_constant, 0)); NOT_REACHED; /* NOTREACHED */ break; - default: NOOP; - } - SvRV_set(gv, NULL); - SvROK_off(gv); + default: NOOP; + } + SvRV_set(gv, NULL); + SvROK_off(gv); } if (old_type < SVt_PVGV) { - if (old_type >= SVt_PV) - SvCUR_set(gv, 0); - sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); + if (old_type >= SVt_PV) + SvCUR_set(gv, 0); + sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); } if (SvLEN(gv)) { - if (proto) { - SvPV_set(gv, NULL); - SvLEN_set(gv, 0); - SvPOK_off(gv); - } else - Safefree(SvPVX_mutable(gv)); + if (proto) { + SvPV_set(gv, NULL); + SvLEN_set(gv, 0); + SvPOK_off(gv); + } else + Safefree(SvPVX_mutable(gv)); } SvIOK_off(gv); isGV_with_GP_on(gv); if (really_sub && !CvISXSUB(has_constant) && CvSTART(has_constant) && ( CvSTART(has_constant)->op_type == OP_NEXTSTATE - || CvSTART(has_constant)->op_type == OP_DBSTATE)) - PL_curcop = (COP *)CvSTART(has_constant); + || CvSTART(has_constant)->op_type == OP_DBSTATE)) + PL_curcop = (COP *)CvSTART(has_constant); GvGP_set(gv, Perl_newGP(aTHX_ gv)); PL_curcop = old; GvSTASH(gv) = stash; if (stash) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 )); if (flags & GV_ADDMULTI || doproto) /* doproto means it */ - GvMULTI_on(gv); /* _was_ mentioned */ + GvMULTI_on(gv); /* _was_ mentioned */ if (really_sub) { - /* Not actually a constant. Just a regular sub. */ - CV * const cv = (CV *)has_constant; - GvCV_set(gv,cv); - if (CvNAMED(cv) && CvSTASH(cv) == stash && ( - CvNAME_HEK(cv) == GvNAME_HEK(gv) - || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv)) - && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv)) - && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv)) - && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv)) - ) - )) - CvGV_set(cv,gv); + /* Not actually a constant. Just a regular sub. */ + CV * const cv = (CV *)has_constant; + GvCV_set(gv,cv); + if (CvNAMED(cv) && CvSTASH(cv) == stash && ( + CvNAME_HEK(cv) == GvNAME_HEK(gv) + || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv)) + && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv)) + && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv)) + && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv)) + ) + )) + CvGV_set(cv,gv); } else if (doproto) { - CV *cv; - if (has_constant) { - /* newCONSTSUB takes ownership of the reference from us. */ - cv = newCONSTSUB_flags(stash, name, len, flags, has_constant); - /* In case op.c:S_process_special_blocks stole it: */ - if (!GvCV(gv)) - GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv)); - assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */ - /* If this reference was a copy of another, then the subroutine - must have been "imported", by a Perl space assignment to a GV - from a reference to CV. */ - if (exported_constant) - GvIMPORTED_CV_on(gv); - CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */ - } else { - cv = newSTUB(gv,1); - } - if (proto) { - sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, - SV_HAS_TRAILING_NUL); + CV *cv; + if (has_constant) { + /* newCONSTSUB takes ownership of the reference from us. */ + cv = newCONSTSUB_flags(stash, name, len, flags, has_constant); + /* In case op.c:S_process_special_blocks stole it: */ + if (!GvCV(gv)) + GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv)); + assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */ + /* If this reference was a copy of another, then the subroutine + must have been "imported", by a Perl space assignment to a GV + from a reference to CV. */ + if (exported_constant) + GvIMPORTED_CV_on(gv); + CvSTASH_set(cv, PL_curstash); /* XXX Why is this needed? */ + } else { + cv = newSTUB(gv,1); + } + if (proto) { + sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen, + SV_HAS_TRAILING_NUL); if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv)); - } + } } } @@ -497,26 +497,26 @@ S_gv_init_svtype(pTHX_ GV *gv, const svtype sv_type) switch (sv_type) { case SVt_PVIO: - (void)GvIOn(gv); - break; + (void)GvIOn(gv); + break; case SVt_PVAV: - (void)GvAVn(gv); - break; + (void)GvAVn(gv); + break; case SVt_PVHV: - (void)GvHVn(gv); - break; + (void)GvHVn(gv); + break; #ifdef PERL_DONT_CREATE_GVSV case SVt_NULL: case SVt_PVCV: case SVt_PVFM: case SVt_PVGV: - break; + break; default: - if(GvSVn(gv)) { - /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 - If we just cast GvSVn(gv) to void, it ignores evaluating it for - its side effect */ - } + if(GvSVn(gv)) { + /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 + If we just cast GvSVn(gv) to void, it ignores evaluating it for + its side effect */ + } #endif } } @@ -562,7 +562,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, case KEY_tr : case KEY_UNITCHECK: case KEY_unless: case KEY_until: case KEY_use : case KEY_when : case KEY_while : case KEY_x : case KEY_xor : case KEY_y : - return NULL; + return NULL; case KEY_chdir: case KEY_chomp: case KEY_chop: case KEY_defined: case KEY_delete: case KEY_eof : case KEY_exec: case KEY_exists : @@ -571,33 +571,33 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, case KEY_stat: case KEY_system: case KEY_truncate: case KEY_unlink: - ampable = FALSE; + ampable = FALSE; } if (!gv) { - gv = (GV *)newSV(0); - gv_init(gv, stash, name, len, TRUE); + gv = (GV *)newSV(0); + gv_init(gv, stash, name, len, TRUE); } GvMULTI_on(gv); if (ampable) { - ENTER; - oldcurcop = PL_curcop; - oldparser = PL_parser; - lex_start(NULL, NULL, 0); - oldcompcv = PL_compcv; - PL_compcv = NULL; /* Prevent start_subparse from setting - CvOUTSIDE. */ - oldsavestack_ix = start_subparse(FALSE,0); - cv = PL_compcv; + ENTER; + oldcurcop = PL_curcop; + oldparser = PL_parser; + lex_start(NULL, NULL, 0); + oldcompcv = PL_compcv; + PL_compcv = NULL; /* Prevent start_subparse from setting + CvOUTSIDE. */ + oldsavestack_ix = start_subparse(FALSE,0); + cv = PL_compcv; } else { - /* Avoid calling newXS, as it calls us, and things start to - get hairy. */ - cv = MUTABLE_CV(newSV_type(SVt_PVCV)); - GvCV_set(gv,cv); - GvCVGEN(gv) = 0; - CvISXSUB_on(cv); - CvXSUB(cv) = core_xsub; - PoisonPADLIST(cv); + /* Avoid calling newXS, as it calls us, and things start to + get hairy. */ + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); + GvCV_set(gv,cv); + GvCVGEN(gv) = 0; + CvISXSUB_on(cv); + CvXSUB(cv) = core_xsub; + PoisonPADLIST(cv); } CvGV_set(cv, gv); /* This stops new ATTRSUB from setting CvFILE from PL_curcop. */ @@ -611,42 +611,42 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, new ATTRSUB. */ (void)core_prototype((SV *)cv, name, code, &opnum); if (stash) - (void)hv_store(stash,name,len,(SV *)gv,0); + (void)hv_store(stash,name,len,(SV *)gv,0); if (ampable) { #ifdef DEBUGGING CV *orig_cv = cv; #endif - CvLVALUE_on(cv); + CvLVALUE_on(cv); /* newATTRSUB will free the CV and return NULL if we're still compiling after a syntax error */ - if ((cv = newATTRSUB_x( - oldsavestack_ix, (OP *)gv, - NULL,NULL, - coresub_op( - opnum - ? newSVuv((UV)opnum) - : newSVpvn(name,len), - code, opnum - ), - TRUE + if ((cv = newATTRSUB_x( + oldsavestack_ix, (OP *)gv, + NULL,NULL, + coresub_op( + opnum + ? newSVuv((UV)opnum) + : newSVpvn(name,len), + code, opnum + ), + TRUE )) != NULL) { assert(GvCV(gv) == orig_cv); if (opnum != OP_VEC && opnum != OP_SUBSTR && opnum != OP_POS && opnum != OP_UNDEF && opnum != OP_KEYS) CvLVALUE_off(cv); /* Now *that* was a neat trick. */ } - LEAVE; - PL_parser = oldparser; - PL_curcop = oldcurcop; - PL_compcv = oldcompcv; + LEAVE; + PL_parser = oldparser; + PL_curcop = oldcurcop; + PL_compcv = oldcompcv; } if (cv) { - SV *opnumsv = newSViv( - (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ? - (OP_ENTEREVAL | (1<<16)) - : opnum ? opnum : (((I32)name[2]) << 16)); + SV *opnumsv = newSViv( + (opnum == OP_ENTEREVAL && len == 9 && memEQ(name, "evalbytes", 9)) ? + (OP_ENTEREVAL | (1<<16)) + : opnum ? opnum : (((I32)name[2]) << 16)); cv_set_call_checker_flags(cv, Perl_ck_entersub_args_core, opnumsv, 0); - SvREFCNT_dec_NN(opnumsv); + SvREFCNT_dec_NN(opnumsv); } return gv; @@ -746,9 +746,9 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, /* UNIVERSAL methods should be callable without a stash */ if (!stash) { - create = 0; /* probably appropriate */ - if(!(stash = gv_stashpvs("UNIVERSAL", 0))) - return 0; + create = 0; /* probably appropriate */ + if(!(stash = gv_stashpvs("UNIVERSAL", 0))) + return 0; } assert(stash); @@ -762,15 +762,15 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, assert(name || meth); DEBUG_o( Perl_deb(aTHX_ "Looking for %smethod %s in package %s\n", - flags & GV_SUPER ? "SUPER " : "", - name ? name : SvPV_nolen(meth), hvname) ); + flags & GV_SUPER ? "SUPER " : "", + name ? name : SvPV_nolen(meth), hvname) ); topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; if (flags & GV_SUPER) { - if (!HvAUX(stash)->xhv_mro_meta->super) - HvAUX(stash)->xhv_mro_meta->super = newHV(); - cachestash = HvAUX(stash)->xhv_mro_meta->super; + if (!HvAUX(stash)->xhv_mro_meta->super) + HvAUX(stash)->xhv_mro_meta->super = newHV(); + cachestash = HvAUX(stash)->xhv_mro_meta->super; } else cachestash = stash; @@ -798,21 +798,21 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, } else { /* stale cache entry, junk it and move on */ - SvREFCNT_dec_NN(cand_cv); - GvCV_set(topgv, NULL); - cand_cv = NULL; - GvCVGEN(topgv) = 0; + SvREFCNT_dec_NN(cand_cv); + GvCV_set(topgv, NULL); + cand_cv = NULL; + GvCVGEN(topgv) = 0; } } else if (GvCVGEN(topgv) == topgen_cmp) { /* cache indicates no such method definitively */ return 0; } - else if (stash == cachestash - && len > 1 /* shortest is uc */ + else if (stash == cachestash + && len > 1 /* shortest is uc */ && memEQs(hvname, HvNAMELEN_get(stash), "CORE") && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len)) - goto have_gv; + goto have_gv; } linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ @@ -885,7 +885,7 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, GvCV_set(topgv, cand_cv); GvCVGEN(topgv) = topgen_cmp; } - return candidate; + return candidate; } } @@ -986,26 +986,26 @@ Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I3 PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD; if (!gv) { - CV *cv; - GV **gvp; - - if (!stash) - return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ - if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) - return NULL; - if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags))) - return NULL; - cv = GvCV(gv); - if (!(CvROOT(cv) || CvXSUB(cv))) - return NULL; - /* Have an autoload */ - if (level < 0) /* Cannot do without a stub */ - gv_fetchmeth_pvn(stash, name, len, 0, flags); - gvp = (GV**)hv_fetch(stash, name, + CV *cv; + GV **gvp; + + if (!stash) + return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ + if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) + return NULL; + if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, flags))) + return NULL; + cv = GvCV(gv); + if (!(CvROOT(cv) || CvXSUB(cv))) + return NULL; + /* Have an autoload */ + if (level < 0) /* Cannot do without a stub */ + gv_fetchmeth_pvn(stash, name, len, 0, flags); + gvp = (GV**)hv_fetch(stash, name, (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0)); - if (!gvp) - return NULL; - return *gvp; + if (!gvp) + return NULL; + return *gvp; } return gv; } @@ -1081,11 +1081,11 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS; if (SvTYPE(stash) < SVt_PVHV) - stash = NULL; + stash = NULL; else { - /* The only way stash can become NULL later on is if last_separator is set, - which in turn means that there is no need for a SVt_PVHV case - the error reporting code. */ + /* The only way stash can become NULL later on is if last_separator is set, + which in turn means that there is no need for a SVt_PVHV case + the error reporting code. */ } { @@ -1118,100 +1118,100 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le if (last_separator) { STRLEN sep_len= last_separator - origname; if ( memEQs(origname, sep_len, "SUPER")) { - /* ->SUPER::method should really be looked up in original stash */ - stash = CopSTASH(PL_curcop); - flags |= GV_SUPER; - DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", - origname, HvENAME_get(stash), name) ); - } + /* ->SUPER::method should really be looked up in original stash */ + stash = CopSTASH(PL_curcop); + flags |= GV_SUPER; + DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", + origname, HvENAME_get(stash), name) ); + } else if ( sep_len >= 7 && - strBEGINs(last_separator - 7, "::SUPER")) { + strBEGINs(last_separator - 7, "::SUPER")) { /* don't autovifify if ->NoSuchStash::SUPER::method */ stash = gv_stashpvn(origname, sep_len - 7, is_utf8); - if (stash) flags |= GV_SUPER; - } - else { + if (stash) flags |= GV_SUPER; + } + else { /* don't autovifify if ->NoSuchStash::method */ stash = gv_stashpvn(origname, sep_len, is_utf8); - } - ostash = stash; + } + ostash = stash; } gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); if (!gv) { - /* This is the special case that exempts Foo->import and - Foo->unimport from being an error even if there's no - import/unimport subroutine */ - if (strEQ(name,"import") || strEQ(name,"unimport")) { - gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL, - NULL, 0, 0, NULL)); - } else if (autoload) - gv = gv_autoload_pvn( - ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags - ); - if (!gv && do_croak) { - /* Right now this is exclusively for the benefit of S_method_common - in pp_hot.c */ - if (stash) { - /* If we can't find an IO::File method, it might be a call on - * a filehandle. If IO:File has not been loaded, try to - * require it first instead of croaking */ - const char *stash_name = HvNAME_get(stash); - if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") - && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, - STR_WITH_LEN("IO/File.pm"), 0, - HV_FETCH_ISEXISTS, NULL, 0) - ) { - require_pv("IO/File.pm"); - gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); - if (gv) - return gv; - } - Perl_croak(aTHX_ - "Can't locate object method \"%" UTF8f - "\" via package \"%" HEKf "\"", - UTF8fARG(is_utf8, name_end - name, name), + /* This is the special case that exempts Foo->import and + Foo->unimport from being an error even if there's no + import/unimport subroutine */ + if (strEQ(name,"import") || strEQ(name,"unimport")) { + gv = (GV*)sv_2mortal((SV*)newCONSTSUB_flags(NULL, + NULL, 0, 0, NULL)); + } else if (autoload) + gv = gv_autoload_pvn( + ostash, name, name_end - name, GV_AUTOLOAD_ISMETHOD|flags + ); + if (!gv && do_croak) { + /* Right now this is exclusively for the benefit of S_method_common + in pp_hot.c */ + if (stash) { + /* If we can't find an IO::File method, it might be a call on + * a filehandle. If IO:File has not been loaded, try to + * require it first instead of croaking */ + const char *stash_name = HvNAME_get(stash); + if (stash_name && memEQs(stash_name, HvNAMELEN_get(stash), "IO::File") + && !Perl_hv_common(aTHX_ GvHVn(PL_incgv), NULL, + STR_WITH_LEN("IO/File.pm"), 0, + HV_FETCH_ISEXISTS, NULL, 0) + ) { + require_pv("IO/File.pm"); + gv = gv_fetchmeth_pvn(stash, name, name_end - name, 0, flags); + if (gv) + return gv; + } + Perl_croak(aTHX_ + "Can't locate object method \"%" UTF8f + "\" via package \"%" HEKf "\"", + UTF8fARG(is_utf8, name_end - name, name), HEKfARG(HvNAME_HEK(stash))); - } - else { + } + else { SV* packnamesv; - if (last_separator) { - packnamesv = newSVpvn_flags(origname, last_separator - origname, + if (last_separator) { + packnamesv = newSVpvn_flags(origname, last_separator - origname, SVs_TEMP | is_utf8); - } else { - packnamesv = error_report; - } - - Perl_croak(aTHX_ - "Can't locate object method \"%" UTF8f - "\" via package \"%" SVf "\"" - " (perhaps you forgot to load \"%" SVf "\"?)", - UTF8fARG(is_utf8, name_end - name, name), + } else { + packnamesv = error_report; + } + + Perl_croak(aTHX_ + "Can't locate object method \"%" UTF8f + "\" via package \"%" SVf "\"" + " (perhaps you forgot to load \"%" SVf "\"?)", + UTF8fARG(is_utf8, name_end - name, name), SVfARG(packnamesv), SVfARG(packnamesv)); - } - } + } + } } else if (autoload) { - CV* const cv = GvCV(gv); - if (!CvROOT(cv) && !CvXSUB(cv)) { - GV* stubgv; - GV* autogv; - - if (CvANON(cv) || CvLEXICAL(cv)) - stubgv = gv; - else { - stubgv = CvGV(cv); - if (GvCV(stubgv) != cv) /* orphaned import */ - stubgv = gv; - } + CV* const cv = GvCV(gv); + if (!CvROOT(cv) && !CvXSUB(cv)) { + GV* stubgv; + GV* autogv; + + if (CvANON(cv) || CvLEXICAL(cv)) + stubgv = gv; + else { + stubgv = CvGV(cv); + if (GvCV(stubgv) != cv) /* orphaned import */ + stubgv = gv; + } autogv = gv_autoload_pvn(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), GV_AUTOLOAD_ISMETHOD | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0)); - if (autogv) - gv = autogv; - } + if (autogv) + gv = autogv; + } } return gv; @@ -1250,26 +1250,26 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN; if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) - return NULL; + return NULL; if (stash) { - if (SvTYPE(stash) < SVt_PVHV) { + if (SvTYPE(stash) < SVt_PVHV) { STRLEN packname_len = 0; const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len); packname = newSVpvn_flags(packname_ptr, packname_len, SVs_TEMP | SvUTF8(stash)); - stash = NULL; - } - else - packname = sv_2mortal(newSVhek(HvNAME_HEK(stash))); - if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); + stash = NULL; + } + else + packname = sv_2mortal(newSVhek(HvNAME_HEK(stash))); + if (flags & GV_SUPER) sv_catpvs(packname, "::SUPER"); } if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, - is_utf8 | (flags & GV_SUPER)))) - return NULL; + is_utf8 | (flags & GV_SUPER)))) + return NULL; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) - return NULL; + return NULL; /* * Inheriting AUTOLOAD for non-methods no longer works @@ -1280,7 +1280,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) ) Perl_croak(aTHX_ "Use of inherited AUTOLOAD for non-method %" SVf "::%" UTF8f "() is no longer allowed", - SVfARG(packname), + SVfARG(packname), UTF8fARG(is_utf8, len, name)); if (CvISXSUB(cv)) { @@ -1306,34 +1306,34 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) * We use SvUTF8 for both prototypes and sub names, so if one is * UTF8, the other must be upgraded. */ - CvSTASH_set(cv, stash); - if (SvPOK(cv)) { /* Ouch! */ - SV * const tmpsv = newSVpvn_flags(name, len, is_utf8); - STRLEN ulen; - const char *proto = CvPROTO(cv); - assert(proto); - if (SvUTF8(cv)) - sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2); - ulen = SvCUR(tmpsv); - SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */ - sv_catpvn_flags( - tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv) - ); - SvTEMP_on(tmpsv); /* Allow theft */ - sv_setsv_nomg((SV *)cv, tmpsv); - SvTEMP_off(tmpsv); - SvREFCNT_dec_NN(tmpsv); - SvLEN_set(cv, SvCUR(cv) + 1); - SvCUR_set(cv, ulen); - } - else { - sv_setpvn((SV *)cv, name, len); - SvPOK_off(cv); - if (is_utf8) + CvSTASH_set(cv, stash); + if (SvPOK(cv)) { /* Ouch! */ + SV * const tmpsv = newSVpvn_flags(name, len, is_utf8); + STRLEN ulen; + const char *proto = CvPROTO(cv); + assert(proto); + if (SvUTF8(cv)) + sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2); + ulen = SvCUR(tmpsv); + SvCUR_set(tmpsv, SvCUR(tmpsv) + 1); /* include null in string */ + sv_catpvn_flags( + tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv) + ); + SvTEMP_on(tmpsv); /* Allow theft */ + sv_setsv_nomg((SV *)cv, tmpsv); + SvTEMP_off(tmpsv); + SvREFCNT_dec_NN(tmpsv); + SvLEN_set(cv, SvCUR(cv) + 1); + SvCUR_set(cv, ulen); + } + else { + sv_setpvn((SV *)cv, name, len); + SvPOK_off(cv); + if (is_utf8) SvUTF8_on(cv); - else SvUTF8_off(cv); - } - CvAUTOLOAD_on(cv); + else SvUTF8_off(cv); + } + CvAUTOLOAD_on(cv); } /* @@ -1347,9 +1347,9 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) ENTER; if (!isGV(vargv)) { - gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0); + gv_init_pvn(vargv, varstash, S_autoload, S_autolen, 0); #ifdef PERL_DONT_CREATE_GVSV - GvSV(vargv) = newSV(0); + GvSV(vargv) = newSV(0); #endif } LEAVE; @@ -1361,8 +1361,8 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear tainting if $FOO::AUTOLOAD was previously tainted, but is not now. */ sv_catpvn_flags( - varsv, name, len, - SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES) + varsv, name, len, + SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES) ); if (is_utf8) SvUTF8_on(varsv); @@ -1413,19 +1413,19 @@ S_require_tie_mod(pTHX_ GV *gv, const char varname, const char * name, if (!(stash = gv_stashpvn(name, len, 0)) || ! GET_HV_FETCH_TIE_FUNC) { - SV * const module = newSVpvn(name, len); - const char type = varname == '[' ? '$' : '%'; - if ( flags & 1 ) - save_scalar(gv); - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); - assert(sp == PL_stack_sp); - stash = gv_stashpvn(name, len, 0); - if (!stash) - Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", - type, varname, name); - else if (! GET_HV_FETCH_TIE_FUNC) - Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", - type, varname, name); + SV * const module = newSVpvn(name, len); + const char type = varname == '[' ? '$' : '%'; + if ( flags & 1 ) + save_scalar(gv); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); + assert(sp == PL_stack_sp); + stash = gv_stashpvn(name, len, 0); + if (!stash) + Perl_croak(aTHX_ "panic: Can't use %c%c because %s is not available", + type, varname, name); + else if (! GET_HV_FETCH_TIE_FUNC) + Perl_croak(aTHX_ "panic: Can't use %c%c because %s does not define _tie_it", + type, varname, name); } /* Now call the tie function. It should be in *gvp. */ assert(gvp); assert(*gvp); @@ -1516,28 +1516,28 @@ S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags) PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL; if (tmplen <= sizeof smallbuf) - tmpbuf = smallbuf; + tmpbuf = smallbuf; else - Newx(tmpbuf, tmplen, char); + Newx(tmpbuf, tmplen, char); Copy(name, tmpbuf, namelen, char); tmpbuf[namelen] = ':'; tmpbuf[namelen+1] = ':'; tmpgv = gv_fetchpvn_flags(tmpbuf, tmplen, flags, SVt_PVHV); if (tmpbuf != smallbuf) - Safefree(tmpbuf); + Safefree(tmpbuf); if (!tmpgv || !isGV_with_GP(tmpgv)) - return NULL; + return NULL; stash = GvHV(tmpgv); if (!(flags & ~GV_NOADD_MASK) && !stash) return NULL; assert(stash); if (!HvNAME_get(stash)) { - hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); - - /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ - /* If the containing stash has multiple effective - names, see that this one gets them, too. */ - if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) - mro_package_moved(stash, NULL, tmpgv, 1); + hv_name_set(stash, name, namelen, flags & SVf_UTF8 ? SVf_UTF8 : 0 ); + + /* FIXME: This is a repeat of logic in gv_fetchpvn_flags */ + /* If the containing stash has multiple effective + names, see that this one gets them, too. */ + if (HvAUX(GvSTASH(tmpgv))->xhv_name_count) + mro_package_moved(stash, NULL, tmpgv, 1); } return stash; } @@ -1653,7 +1653,7 @@ S_gv_magicalize_isa(pTHX_ GV *gv) av = GvAVn(gv); GvMULTI_on(gv); sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, - NULL, 0); + NULL, 0); } /* This function grabs name and tries to split a stash and glob @@ -1753,14 +1753,14 @@ S_parse_gv_stash_name(pTHX_ HV **stash, GV **gv, const char **name, *name = name_cursor+1; if (*name == name_end) { if (!*gv) { - *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); - if (SvTYPE(*gv) != SVt_PVGV) { - gv_init_pvn(*gv, PL_defstash, "main::", 6, - GV_ADDMULTI); - GvHV(*gv) = - MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); - } - } + *gv = MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); + if (SvTYPE(*gv) != SVt_PVGV) { + gv_init_pvn(*gv, PL_defstash, "main::", 6, + GV_ADDMULTI); + GvHV(*gv) = + MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); + } + } goto ok; } } @@ -1954,12 +1954,12 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, PERL_ARGS_ASSERT_GV_MAGICALIZE; if (stash != PL_defstash) { /* not the main stash */ - /* We only have to check for a few names here: a, b, EXPORT, ISA - and VERSION. All the others apply only to the main stash or to - CORE (which is checked right after this). */ - if (len) { - switch (*name) { - case 'E': + /* We only have to check for a few names here: a, b, EXPORT, ISA + and VERSION. All the others apply only to the main stash or to + CORE (which is checked right after this). */ + if (len) { + switch (*name) { + case 'E': if ( len >= 6 && name[1] == 'X' && (memEQs(name, len, "EXPORT") @@ -1967,46 +1967,46 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, ||memEQs(name, len, "EXPORT_FAIL") ||memEQs(name, len, "EXPORT_TAGS")) ) - GvMULTI_on(gv); - break; - case 'I': + GvMULTI_on(gv); + break; + case 'I': if (memEQs(name, len, "ISA")) - gv_magicalize_isa(gv); - break; - case 'V': + gv_magicalize_isa(gv); + break; + case 'V': if (memEQs(name, len, "VERSION")) - GvMULTI_on(gv); - break; - case 'a': + GvMULTI_on(gv); + break; + case 'a': if (stash == PL_debstash && memEQs(name, len, "args")) { - GvMULTI_on(gv_AVadd(gv)); - break; + GvMULTI_on(gv_AVadd(gv)); + break; } /* FALLTHROUGH */ - case 'b': - if (len == 1 && sv_type == SVt_PV) - GvMULTI_on(gv); - /* FALLTHROUGH */ - default: - goto try_core; - } - goto ret; - } + case 'b': + if (len == 1 && sv_type == SVt_PV) + GvMULTI_on(gv); + /* FALLTHROUGH */ + default: + goto try_core; + } + goto ret; + } try_core: - if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { - /* Avoid null warning: */ - const char * const stashname = HvNAME(stash); assert(stashname); - if (strBEGINs(stashname, "CORE")) - S_maybe_add_coresub(aTHX_ 0, gv, name, len); - } + if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) { + /* Avoid null warning: */ + const char * const stashname = HvNAME(stash); assert(stashname); + if (strBEGINs(stashname, "CORE")) + S_maybe_add_coresub(aTHX_ 0, gv, name, len); + } } else if (len > 1) { #ifndef EBCDIC - if (*name > 'V' ) { - NOOP; - /* Nothing else to do. - The compiler will probably turn the switch statement into a - branch table. Make sure we avoid even that small overhead for + if (*name > 'V' ) { + NOOP; + /* Nothing else to do. + The compiler will probably turn the switch statement into a + branch table. Make sure we avoid even that small overhead for the common case of lower case variable names. (On EBCDIC platforms, we can't just do: if (NATIVE_TO_ASCII(*name) > NATIVE_TO_ASCII('V') ) { @@ -2014,19 +2014,19 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, C1 (non-ASCII) controls on those platforms, so the remapping would make them larger than 'V') */ - } else + } else #endif - { - switch (*name) { - case 'A': + { + switch (*name) { + case 'A': if (memEQs(name, len, "ARGV")) { - IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; - } + IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; + } else if (memEQs(name, len, "ARGVOUT")) { - GvMULTI_on(gv); - } - break; - case 'E': + GvMULTI_on(gv); + } + break; + case 'E': if ( len >= 6 && name[1] == 'X' && (memEQs(name, len, "EXPORT") @@ -2034,51 +2034,51 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, ||memEQs(name, len, "EXPORT_FAIL") ||memEQs(name, len, "EXPORT_TAGS")) ) - GvMULTI_on(gv); - break; - case 'I': + GvMULTI_on(gv); + break; + case 'I': if (memEQs(name, len, "ISA")) { - gv_magicalize_isa(gv); - } - break; - case 'S': + gv_magicalize_isa(gv); + } + break; + case 'S': if (memEQs(name, len, "SIG")) { - HV *hv; - I32 i; - if (!PL_psig_name) { - Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); - Newxz(PL_psig_pend, SIG_SIZE, int); - PL_psig_ptr = PL_psig_name + SIG_SIZE; - } else { - /* I think that the only way to get here is to re-use an - embedded perl interpreter, where the previous - use didn't clean up fully because - PL_perl_destruct_level was 0. I'm not sure that we - "support" that, in that I suspect in that scenario - there are sufficient other garbage values left in the - interpreter structure that something else will crash - before we get here. I suspect that this is one of - those "doctor, it hurts when I do this" bugs. */ - Zero(PL_psig_name, 2 * SIG_SIZE, SV*); - Zero(PL_psig_pend, SIG_SIZE, int); - } - GvMULTI_on(gv); - hv = GvHVn(gv); - hv_magic(hv, NULL, PERL_MAGIC_sig); - for (i = 1; i < SIG_SIZE; i++) { - SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); - if (init) - sv_setsv(*init, &PL_sv_undef); - } - } - break; - case 'V': + HV *hv; + I32 i; + if (!PL_psig_name) { + Newxz(PL_psig_name, 2 * SIG_SIZE, SV*); + Newxz(PL_psig_pend, SIG_SIZE, int); + PL_psig_ptr = PL_psig_name + SIG_SIZE; + } else { + /* I think that the only way to get here is to re-use an + embedded perl interpreter, where the previous + use didn't clean up fully because + PL_perl_destruct_level was 0. I'm not sure that we + "support" that, in that I suspect in that scenario + there are sufficient other garbage values left in the + interpreter structure that something else will crash + before we get here. I suspect that this is one of + those "doctor, it hurts when I do this" bugs. */ + Zero(PL_psig_name, 2 * SIG_SIZE, SV*); + Zero(PL_psig_pend, SIG_SIZE, int); + } + GvMULTI_on(gv); + hv = GvHVn(gv); + hv_magic(hv, NULL, PERL_MAGIC_sig); + for (i = 1; i < SIG_SIZE; i++) { + SV * const * const init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); + if (init) + sv_setsv(*init, &PL_sv_undef); + } + } + break; + case 'V': if (memEQs(name, len, "VERSION")) - GvMULTI_on(gv); - break; + GvMULTI_on(gv); + break; case '\003': /* $^CHILD_ERROR_NATIVE */ if (memEQs(name, len, "\003HILD_ERROR_NATIVE")) - goto magicalize; + goto magicalize; /* @{^CAPTURE} %{^CAPTURE} */ if (memEQs(name, len, "\003APTURE")) { AV* const av = GvAVn(gv); @@ -2093,30 +2093,30 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, if (memEQs(name, len, "\003APTURE_ALL")) { require_tie_mod_s(gv, '-', "Tie::Hash::NamedCapture",0); } - break; - case '\005': /* $^ENCODING */ + break; + case '\005': /* $^ENCODING */ if (memEQs(name, len, "\005NCODING")) - goto magicalize; - break; - case '\007': /* $^GLOBAL_PHASE */ + goto magicalize; + break; + case '\007': /* $^GLOBAL_PHASE */ if (memEQs(name, len, "\007LOBAL_PHASE")) - goto ro_magicalize; - break; - case '\014': /* $^LAST_FH */ + goto ro_magicalize; + break; + case '\014': /* $^LAST_FH */ if (memEQs(name, len, "\014AST_FH")) - goto ro_magicalize; - break; + goto ro_magicalize; + break; case '\015': /* $^MATCH */ if (memEQs(name, len, "\015ATCH")) { paren = RX_BUFF_IDX_CARET_FULLMATCH; goto storeparen; } break; - case '\017': /* $^OPEN */ + case '\017': /* $^OPEN */ if (memEQs(name, len, "\017PEN")) - goto magicalize; - break; - case '\020': /* $^PREMATCH $^POSTMATCH */ + goto magicalize; + break; + case '\020': /* $^PREMATCH $^POSTMATCH */ if (memEQs(name, len, "\020REMATCH")) { paren = RX_BUFF_IDX_CARET_PREMATCH; goto storeparen; @@ -2125,73 +2125,73 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, paren = RX_BUFF_IDX_CARET_POSTMATCH; goto storeparen; } - break; + break; case '\023': if (memEQs(name, len, "\023AFE_LOCALES")) - goto ro_magicalize; - break; - case '\024': /* ${^TAINT} */ + goto ro_magicalize; + break; + case '\024': /* ${^TAINT} */ if (memEQs(name, len, "\024AINT")) - goto ro_magicalize; - break; - case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ + goto ro_magicalize; + break; + case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ if (memEQs(name, len, "\025NICODE")) - goto ro_magicalize; + goto ro_magicalize; if (memEQs(name, len, "\025TF8LOCALE")) - goto ro_magicalize; + goto ro_magicalize; if (memEQs(name, len, "\025TF8CACHE")) - goto magicalize; - break; - case '\027': /* $^WARNING_BITS */ + goto magicalize; + break; + case '\027': /* $^WARNING_BITS */ if (memEQs(name, len, "\027ARNING_BITS")) - goto magicalize; + goto magicalize; #ifdef WIN32 else if (memEQs(name, len, "\027IN32_SLOPPY_STAT")) - goto magicalize; + goto magicalize; #endif - break; - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - { - /* Ensures that we have an all-digit variable, ${"1foo"} fails - this test */ + break; + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + { + /* Ensures that we have an all-digit variable, ${"1foo"} fails + this test */ UV uv; if (!grok_atoUV(name, &uv, NULL) || uv > I32_MAX) goto ret; /* XXX why are we using a SSize_t? */ paren = (SSize_t)(I32)uv; goto storeparen; - } - } - } + } + } + } } else { - /* Names of length 1. (Or 0. But name is NUL terminated, so that will - be case '\0' in this switch statement (ie a default case) */ - switch (*name) { - case '&': /* $& */ + /* Names of length 1. (Or 0. But name is NUL terminated, so that will + be case '\0' in this switch statement (ie a default case) */ + switch (*name) { + case '&': /* $& */ paren = RX_BUFF_IDX_FULLMATCH; goto sawampersand; - case '`': /* $` */ + case '`': /* $` */ paren = RX_BUFF_IDX_PREMATCH; goto sawampersand; - case '\'': /* $' */ + case '\'': /* $' */ paren = RX_BUFF_IDX_POSTMATCH; sawampersand: #ifdef PERL_SAWAMPERSAND - if (!( - sv_type == SVt_PVAV || - sv_type == SVt_PVHV || - sv_type == SVt_PVCV || - sv_type == SVt_PVFM || - sv_type == SVt_PVIO - )) { PL_sawampersand |= + if (!( + sv_type == SVt_PVAV || + sv_type == SVt_PVHV || + sv_type == SVt_PVCV || + sv_type == SVt_PVFM || + sv_type == SVt_PVIO + )) { PL_sawampersand |= (*name == '`') ? SAWAMPERSAND_LEFT : (*name == '&') @@ -2217,29 +2217,29 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, NULL, paren); break; - case ':': /* $: */ - sv_setpv(GvSVn(gv),PL_chopset); - goto magicalize; + case ':': /* $: */ + sv_setpv(GvSVn(gv),PL_chopset); + goto magicalize; - case '?': /* $? */ + case '?': /* $? */ #ifdef COMPLEX_STATUS - SvUPGRADE(GvSVn(gv), SVt_PVLV); + SvUPGRADE(GvSVn(gv), SVt_PVLV); #endif - goto magicalize; + goto magicalize; - case '!': /* $! */ - GvMULTI_on(gv); - /* If %! has been used, automatically load Errno.pm. */ + case '!': /* $! */ + GvMULTI_on(gv); + /* If %! has been used, automatically load Errno.pm. */ - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); /* magicalization must be done before require_tie_mod_s is called */ - if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) require_tie_mod_s(gv, '!', "Errno", 1); - break; - case '-': /* $-, %-, @- */ - case '+': /* $+, %+, @+ */ + break; + case '-': /* $-, %-, @- */ + case '+': /* $+, %+, @+ */ GvMULTI_on(gv); /* no used once warnings here */ { /* $- $+ */ sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); @@ -2258,81 +2258,81 @@ S_gv_magicalize(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, SvREADONLY_on(av); } break; - case '*': /* $* */ - case '#': /* $# */ + case '*': /* $* */ + case '#': /* $# */ if (sv_type == SVt_PV) /* diag_listed_as: $* is no longer supported as of Perl 5.30 */ Perl_croak(aTHX_ "$%c is no longer supported as of Perl 5.30", *name); break; - case '\010': /* $^H */ - { - HV *const hv = GvHVn(gv); - hv_magic(hv, NULL, PERL_MAGIC_hints); - } - goto magicalize; - case '\023': /* $^S */ - ro_magicalize: - SvREADONLY_on(GvSVn(gv)); - /* FALLTHROUGH */ - case '0': /* $0 */ - case '^': /* $^ */ - case '~': /* $~ */ - case '=': /* $= */ - case '%': /* $% */ - case '.': /* $. */ - case '(': /* $( */ - case ')': /* $) */ - case '<': /* $< */ - case '>': /* $> */ - case '\\': /* $\ */ - case '/': /* $/ */ - case '|': /* $| */ - case '$': /* $$ */ - case '[': /* $[ */ - case '\001': /* $^A */ - case '\003': /* $^C */ - case '\004': /* $^D */ - case '\005': /* $^E */ - case '\006': /* $^F */ - case '\011': /* $^I, NOT \t in EBCDIC */ - case '\016': /* $^N */ - case '\017': /* $^O */ - case '\020': /* $^P */ - case '\024': /* $^T */ - case '\027': /* $^W */ - magicalize: - sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); - break; - - case '\014': /* $^L */ - sv_setpvs(GvSVn(gv),"\f"); - break; - case ';': /* $; */ - sv_setpvs(GvSVn(gv),"\034"); - break; - case ']': /* $] */ - { - SV * const sv = GvSV(gv); - if (!sv_derived_from(PL_patchlevel, "version")) - upg_version(PL_patchlevel, TRUE); - GvSV(gv) = vnumify(PL_patchlevel); - SvREADONLY_on(GvSV(gv)); - SvREFCNT_dec(sv); - } - break; - case '\026': /* $^V */ - { - SV * const sv = GvSV(gv); - GvSV(gv) = new_version(PL_patchlevel); - SvREADONLY_on(GvSV(gv)); - SvREFCNT_dec(sv); - } - break; - case 'a': - case 'b': - if (sv_type == SVt_PV) - GvMULTI_on(gv); - } + case '\010': /* $^H */ + { + HV *const hv = GvHVn(gv); + hv_magic(hv, NULL, PERL_MAGIC_hints); + } + goto magicalize; + case '\023': /* $^S */ + ro_magicalize: + SvREADONLY_on(GvSVn(gv)); + /* FALLTHROUGH */ + case '0': /* $0 */ + case '^': /* $^ */ + case '~': /* $~ */ + case '=': /* $= */ + case '%': /* $% */ + case '.': /* $. */ + case '(': /* $( */ + case ')': /* $) */ + case '<': /* $< */ + case '>': /* $> */ + case '\\': /* $\ */ + case '/': /* $/ */ + case '|': /* $| */ + case '$': /* $$ */ + case '[': /* $[ */ + case '\001': /* $^A */ + case '\003': /* $^C */ + case '\004': /* $^D */ + case '\005': /* $^E */ + case '\006': /* $^F */ + case '\011': /* $^I, NOT \t in EBCDIC */ + case '\016': /* $^N */ + case '\017': /* $^O */ + case '\020': /* $^P */ + case '\024': /* $^T */ + case '\027': /* $^W */ + magicalize: + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + break; + + case '\014': /* $^L */ + sv_setpvs(GvSVn(gv),"\f"); + break; + case ';': /* $; */ + sv_setpvs(GvSVn(gv),"\034"); + break; + case ']': /* $] */ + { + SV * const sv = GvSV(gv); + if (!sv_derived_from(PL_patchlevel, "version")) + upg_version(PL_patchlevel, TRUE); + GvSV(gv) = vnumify(PL_patchlevel); + SvREADONLY_on(GvSV(gv)); + SvREFCNT_dec(sv); + } + break; + case '\026': /* $^V */ + { + SV * const sv = GvSV(gv); + GvSV(gv) = new_version(PL_patchlevel); + SvREADONLY_on(GvSV(gv)); + SvREFCNT_dec(sv); + } + break; + case 'a': + case 'b': + if (sv_type == SVt_PV) + GvMULTI_on(gv); + } } ret: @@ -2461,7 +2461,7 @@ to C<gv_fetchsv> makes it behave identically to C<gv_fetchsv_nomg>. GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, - const svtype sv_type) + const svtype sv_type) { const char *name = nambeg; GV *gv = NULL; @@ -2500,8 +2500,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* By this point we should have a stash and a name */ gvp = (GV**)hv_fetch(stash,name,is_utf8 ? -(I32)len : (I32)len,add); if (!gvp || *gvp == (const GV *)&PL_sv_undef) { - if (addmg) gv = (GV *)newSV(0); /* tentatively */ - else return NULL; + if (addmg) gv = (GV *)newSV(0); /* tentatively */ + else return NULL; } else gv = *gvp, addmg = 0; /* From this point on, addmg means gv has not been inserted in the @@ -2511,7 +2511,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, /* The GV already exists, so return it, but check if we need to do * anything else with it before that. */ - if (add) { + if (add) { /* This is the heuristic that handles if a variable triggers the * 'used only once' warning. If there's already a GV in the stash * with this name, then we assume that the variable has been used @@ -2520,24 +2520,24 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, * BEGIN { $a = 1; $::{foo} = *a }; () = $foo * not warning about $main::foo being used just once */ - GvMULTI_on(gv); - gv_init_svtype(gv, sv_type); + GvMULTI_on(gv); + gv_init_svtype(gv, sv_type); /* You reach this path once the typeglob has already been created, either by the same or a different sigil. If this path didn't exist, then (say) referencing $! first, and %! second would mean that %! was not handled correctly. */ - if (len == 1 && stash == PL_defstash) { + if (len == 1 && stash == PL_defstash) { maybe_multimagic_gv(gv, name, sv_type); - } + } else if (sv_type == SVt_PVAV - && memEQs(name, len, "ISA") - && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) - gv_magicalize_isa(gv); - } - return gv; + && memEQs(name, len, "ISA") + && (!GvAV(gv) || !SvSMAGICAL(GvAV(gv)))) + gv_magicalize_isa(gv); + } + return gv; } else if (no_init) { - assert(!addmg); - return gv; + assert(!addmg); + return gv; } /* If GV_NOEXPAND is true and what we got off the stash is a ref, * don't expand it to a glob. This is an optimization so that things @@ -2546,8 +2546,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, * stashes. */ else if (no_expand && SvROK(gv)) { - assert(!addmg); - return gv; + assert(!addmg); + return gv; } /* Adding a new symbol. @@ -2560,9 +2560,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, faking_it = SvOK(gv); if (add & GV_ADDWARN) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Had to create %" UTF8f " unexpectedly", - UTF8fARG(is_utf8, name_end-nambeg, nambeg)); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Had to create %" UTF8f " unexpectedly", + UTF8fARG(is_utf8, name_end-nambeg, nambeg)); gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); if ( full_len != 0 @@ -2607,8 +2607,8 @@ Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) if (hv && (name = HvNAME(hv))) { const STRLEN len = HvNAMELEN(hv); if (keepmain || ! memBEGINs(name, len, "main")) { - sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES); - sv_catpvs(sv,"::"); + sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES); + sv_catpvs(sv,"::"); } } else sv_catpvs(sv,"__ANON__::"); @@ -2638,7 +2638,7 @@ Perl_gv_check(pTHX_ HV *stash) PERL_ARGS_ASSERT_GV_CHECK; if (!SvOOK(stash)) - return; + return; assert(HvARRAY(stash)); @@ -2646,21 +2646,21 @@ Perl_gv_check(pTHX_ HV *stash) const HE *entry; /* mark stash is being scanned, to avoid recursing */ HvAUX(stash)->xhv_aux_flags |= HvAUXf_SCAN_STASH; - for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { + for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { GV *gv; HV *hv; - STRLEN keylen = HeKLEN(entry); + STRLEN keylen = HeKLEN(entry); const char * const key = HeKEY(entry); - if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' && - (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) - { - if (hv != PL_defstash && hv != stash + if (keylen >= 2 && key[keylen-2] == ':' && key[keylen-1] == ':' && + (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) + { + if (hv != PL_defstash && hv != stash && !(SvOOK(hv) && (HvAUX(hv)->xhv_aux_flags & HvAUXf_SCAN_STASH)) ) - gv_check(hv); /* nested package */ - } + gv_check(hv); /* nested package */ + } else if ( HeKLEN(entry) != 0 && *HeKEY(entry) != '_' && isIDFIRST_lazy_if_safe(HeKEY(entry), @@ -2668,24 +2668,24 @@ Perl_gv_check(pTHX_ HV *stash) HeUTF8(entry)) ) { const char *file; - gv = MUTABLE_GV(HeVAL(entry)); - if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) - continue; - file = GvFILE(gv); - CopLINE_set(PL_curcop, GvLINE(gv)); + gv = MUTABLE_GV(HeVAL(entry)); + if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) + continue; + file = GvFILE(gv); + CopLINE_set(PL_curcop, GvLINE(gv)); #ifdef USE_ITHREADS - CopFILE(PL_curcop) = (char *)file; /* set for warning */ + CopFILE(PL_curcop) = (char *)file; /* set for warning */ #else - CopFILEGV(PL_curcop) - = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); + CopFILEGV(PL_curcop) + = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); #endif - Perl_warner(aTHX_ packWARN(WARN_ONCE), - "Name \"%" HEKf "::%" HEKf - "\" used only once: possible typo", + Perl_warner(aTHX_ packWARN(WARN_ONCE), + "Name \"%" HEKf "::%" HEKf + "\" used only once: possible typo", HEKfARG(HvNAME_HEK(stash)), HEKfARG(GvNAME_HEK(gv))); - } - } + } + } HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_SCAN_STASH; } } @@ -2708,17 +2708,17 @@ GP* Perl_gp_ref(pTHX_ GP *gp) { if (!gp) - return NULL; + return NULL; gp->gp_refcnt++; if (gp->gp_cv) { - if (gp->gp_cvgen) { - /* If the GP they asked for a reference to contains + if (gp->gp_cvgen) { + /* If the GP they asked for a reference to contains a method cache entry, clear it first, so that we don't infect them with our cached entry */ - SvREFCNT_dec_NN(gp->gp_cv); - gp->gp_cv = NULL; - gp->gp_cvgen = 0; - } + SvREFCNT_dec_NN(gp->gp_cv); + gp->gp_cv = NULL; + gp->gp_cvgen = 0; + } } return gp; } @@ -2730,19 +2730,19 @@ Perl_gp_free(pTHX_ GV *gv) int attempts = 100; if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) - return; + return; if (gp->gp_refcnt == 0) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free unreferenced glob pointers" - pTHX__FORMAT pTHX__VALUE); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free unreferenced glob pointers" + pTHX__FORMAT pTHX__VALUE); return; } if (gp->gp_refcnt > 1) { borrowed: - if (gp->gp_egv == gv) - gp->gp_egv = 0; - gp->gp_refcnt--; - GvGP_set(gv, NULL); + if (gp->gp_egv == gv) + gp->gp_egv = 0; + gp->gp_refcnt--; + GvGP_set(gv, NULL); return; } @@ -2766,7 +2766,7 @@ Perl_gp_free(pTHX_ GV *gv) gp->gp_form = NULL; if (file_hek) - unshare_hek(file_hek); + unshare_hek(file_hek); SvREFCNT_dec(sv); SvREFCNT_dec(av); @@ -2780,18 +2780,18 @@ Perl_gp_free(pTHX_ GV *gv) HEKfARG(hvname_hek))); (void)hv_deletehek(PL_stashcache, hvname_hek, G_DISCARD); } - SvREFCNT_dec(hv); + SvREFCNT_dec(hv); } if (io && SvREFCNT(io) == 1 && IoIFP(io) - && (IoTYPE(io) == IoTYPE_WRONLY || - IoTYPE(io) == IoTYPE_RDWR || - IoTYPE(io) == IoTYPE_APPEND) - && ckWARN_d(WARN_IO) - && IoIFP(io) != PerlIO_stdin() - && IoIFP(io) != PerlIO_stdout() - && IoIFP(io) != PerlIO_stderr() - && !(IoFLAGS(io) & IOf_FAKE_DIRP)) - io_close(io, gv, FALSE, TRUE); + && (IoTYPE(io) == IoTYPE_WRONLY || + IoTYPE(io) == IoTYPE_RDWR || + IoTYPE(io) == IoTYPE_APPEND) + && ckWARN_d(WARN_IO) + && IoIFP(io) != PerlIO_stdin() + && IoIFP(io) != PerlIO_stdout() + && IoIFP(io) != PerlIO_stderr() + && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + io_close(io, gv, FALSE, TRUE); SvREFCNT_dec(io); SvREFCNT_dec(cv); SvREFCNT_dec(form); @@ -2808,10 +2808,10 @@ Perl_gp_free(pTHX_ GV *gv) && !gp->gp_form) break; if (--attempts == 0) { - Perl_die(aTHX_ - "panic: gp_free failed to free glob pointer - " - "something is repeatedly re-creating entries" - ); + Perl_die(aTHX_ + "panic: gp_free failed to free glob pointer - " + "something is repeatedly re-creating entries" + ); } } @@ -2830,14 +2830,14 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_FREEOVRLD; if (amtp && AMT_AMAGIC(amtp)) { - int i; - for (i = 1; i < NofAMmeth; i++) { - CV * const cv = amtp->table[i]; - if (cv) { - SvREFCNT_dec_NN(MUTABLE_SV(cv)); - amtp->table[i] = NULL; - } - } + int i; + for (i = 1; i < NofAMmeth; i++) { + CV * const cv = amtp->table[i]; + if (cv) { + SvREFCNT_dec_NN(MUTABLE_SV(cv)); + amtp->table[i] = NULL; + } + } } return 0; } @@ -2863,7 +2863,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (mg) { const AMT * const amtp = (AMT*)mg->mg_ptr; if (amtp->was_ok_sub == newgen) { - return AMT_AMAGIC(amtp) ? 1 : 0; + return AMT_AMAGIC(amtp) ? 1 : 0; } sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); } @@ -2891,19 +2891,19 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (!gv) { if (!gv_fetchmeth_pvn(stash, "((", 2, -1, 0)) - goto no_table; + goto no_table; } #ifdef PERL_DONT_CREATE_GVSV else if (!sv) { - NOOP; /* Equivalent to !SvTRUE and !SvOK */ + NOOP; /* Equivalent to !SvTRUE and !SvOK */ } #endif else if (SvTRUE(sv)) /* don't need to set overloading here because fallback => 1 * is the default setting for classes without overloading */ - amt.fallback=AMGfallYES; + amt.fallback=AMGfallYES; else if (SvOK(sv)) { - amt.fallback=AMGfallNEVER; + amt.fallback=AMGfallNEVER; filled = 1; } else { @@ -2915,21 +2915,21 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF; for (i = 1; i < NofAMmeth; i++) { - const char * const cooky = PL_AMG_names[i]; - /* Human-readable form, for debugging: */ - const char * const cp = AMG_id2name(i); - const STRLEN l = PL_AMG_namelens[i]; - - DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", - cp, HvNAME_get(stash)) ); - /* don't fill the cache while looking up! - Creation of inheritance stubs in intermediate packages may - conflict with the logic of runtime method substitution. - Indeed, for inheritance A -> B -> C, if C overloads "+0", - then we could have created stubs for "(+0" in A and C too. - But if B overloads "bool", we may want to use it for - numifying instead of C's "+0". */ - gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); + const char * const cooky = PL_AMG_names[i]; + /* Human-readable form, for debugging: */ + const char * const cp = AMG_id2name(i); + const STRLEN l = PL_AMG_namelens[i]; + + DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", + cp, HvNAME_get(stash)) ); + /* don't fill the cache while looking up! + Creation of inheritance stubs in intermediate packages may + conflict with the logic of runtime method substitution. + Indeed, for inheritance A -> B -> C, if C overloads "+0", + then we could have created stubs for "(+0" in A and C too. + But if B overloads "bool", we may want to use it for + numifying instead of C's "+0". */ + gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); cv = 0; if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) { const HEK * const gvhek = CvGvNAME_HEK(cv); @@ -2938,49 +2938,49 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil") && stashek && memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload")) { - /* This is a hack to support autoloading..., while - knowing *which* methods were declared as overloaded. */ - /* GvSV contains the name of the method. */ - GV *ngv = NULL; - SV *gvsv = GvSV(gv); - - DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\ - "\" for overloaded \"%s\" in package \"%.256s\"\n", - (void*)GvSV(gv), cp, HvNAME(stash)) ); - if (!gvsv || !SvPOK(gvsv) - || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0))) - { - /* Can be an import stub (created by "can"). */ - if (destructing) { - return -1; - } - else { - const SV * const name = (gvsv && SvPOK(gvsv)) + /* This is a hack to support autoloading..., while + knowing *which* methods were declared as overloaded. */ + /* GvSV contains the name of the method. */ + GV *ngv = NULL; + SV *gvsv = GvSV(gv); + + DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%" SVf256\ + "\" for overloaded \"%s\" in package \"%.256s\"\n", + (void*)GvSV(gv), cp, HvNAME(stash)) ); + if (!gvsv || !SvPOK(gvsv) + || !(ngv = gv_fetchmethod_sv_flags(stash, gvsv, 0))) + { + /* Can be an import stub (created by "can"). */ + if (destructing) { + return -1; + } + else { + const SV * const name = (gvsv && SvPOK(gvsv)) ? gvsv : newSVpvs_flags("???", SVs_TEMP); - /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */ - Perl_croak(aTHX_ "%s method \"%" SVf256 - "\" overloading \"%s\" "\ - "in package \"%" HEKf256 "\"", - (GvCVGEN(gv) ? "Stub found while resolving" - : "Can't resolve"), - SVfARG(name), cp, + /* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */ + Perl_croak(aTHX_ "%s method \"%" SVf256 + "\" overloading \"%s\" "\ + "in package \"%" HEKf256 "\"", + (GvCVGEN(gv) ? "Stub found while resolving" + : "Can't resolve"), + SVfARG(name), cp, HEKfARG( - HvNAME_HEK(stash) - )); - } - } - cv = GvCV(gv = ngv); - } - DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", - cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), - GvNAME(CvGV(cv))) ); - filled = 1; - } else if (gv) { /* Autoloaded... */ - cv = MUTABLE_CV(gv); - filled = 1; - } - amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); + HvNAME_HEK(stash) + )); + } + } + cv = GvCV(gv = ngv); + } + DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", + cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), + GvNAME(CvGV(cv))) ); + filled = 1; + } else if (gv) { /* Autoloaded... */ + cv = MUTABLE_CV(gv); + filled = 1; + } + amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); if (gv) { switch (i) { @@ -3004,7 +3004,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) if (filled) { AMT_AMAGIC_on(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, - (char*)&amt, sizeof(AMT)); + (char*)&amt, sizeof(AMT)); return TRUE; } } @@ -3012,7 +3012,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) no_table: AMT_AMAGIC_off(&amt); sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, - (char*)&amt, sizeof(AMTS)); + (char*)&amt, sizeof(AMTS)); return 0; } @@ -3034,27 +3034,27 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); if (!mg) { do_update: - if (Gv_AMupdate(stash, 0) == -1) - return NULL; - mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); + if (Gv_AMupdate(stash, 0) == -1) + return NULL; + mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); } assert(mg); amtp = (AMT*)mg->mg_ptr; if ( amtp->was_ok_sub != newgen ) - goto do_update; + goto do_update; if (AMT_AMAGIC(amtp)) { - CV * const ret = amtp->table[id]; - if (ret && isGV(ret)) { /* Autoloading stab */ - /* Passing it through may have resulted in a warning - "Inherited AUTOLOAD for a non-method deprecated", since - our caller is going through a function call, not a method call. - So return the CV for AUTOLOAD, setting $AUTOLOAD. */ - GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); - - if (gv && GvCV(gv)) - return GvCV(gv); - } - return ret; + CV * const ret = amtp->table[id]; + if (ret && isGV(ret)) { /* Autoloading stab */ + /* Passing it through may have resulted in a warning + "Inherited AUTOLOAD for a non-method deprecated", since + our caller is going through a function call, not a method call. + So return the CV for AUTOLOAD, setting $AUTOLOAD. */ + GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); + + if (gv && GvCV(gv)) + return GvCV(gv); + } + return ret; } return NULL; @@ -3064,7 +3064,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) /* Implement tryAMAGICun_MG macro. Do get magic, then see if the stack arg is overloaded and if so call it. Flags: - AMGf_numeric apply sv_2num to the stack arg. + AMGf_numeric apply sv_2num to the stack arg. */ bool @@ -3076,8 +3076,8 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { SvGETMAGIC(arg); if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method, - AMGf_noright | AMGf_unary - | (flags & AMGf_numarg)))) + AMGf_noright | AMGf_unary + | (flags & AMGf_numarg)))) { /* where the op is of the form: * $lex = $x op $y (where the assign is optimised away) @@ -3094,12 +3094,12 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { else SETs(tmpsv); - PUTBACK; - return TRUE; + PUTBACK; + return TRUE; } if ((flags & AMGf_numeric) && SvROK(arg)) - *sp = sv_2num(arg); + *sp = sv_2num(arg); return FALSE; } @@ -3108,8 +3108,8 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { Do get magic, then see if the two stack args are overloaded and if so call it. Flags: - AMGf_assign op may be called as mutator (eg +=) - AMGf_numeric apply sv_2num to the stack arg. + AMGf_assign op may be called as mutator (eg +=) + AMGf_numeric apply sv_2num to the stack arg. */ bool @@ -3120,17 +3120,17 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { SvGETMAGIC(left); if (left != right) - SvGETMAGIC(right); + SvGETMAGIC(right); if (SvAMAGIC(left) || SvAMAGIC(right)) { - SV * tmpsv; + SV * tmpsv; /* STACKED implies mutator variant, e.g. $x += 1 */ bool mutator = (flags & AMGf_assign) && (PL_op->op_flags & OPf_STACKED); - tmpsv = amagic_call(left, right, method, - (mutator ? AMGf_assign: 0) - | (flags & AMGf_numarg)); - if (tmpsv) { + tmpsv = amagic_call(left, right, method, + (mutator ? AMGf_assign: 0) + | (flags & AMGf_numarg)); + if (tmpsv) { (void)POPs; /* where the op is one of the two forms: * $x op= $y @@ -3150,28 +3150,28 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { else SETs(tmpsv); - PUTBACK; - return TRUE; - } + PUTBACK; + return TRUE; + } } if(left==right && SvGMAGICAL(left)) { - SV * const left = sv_newmortal(); - *(sp-1) = left; - /* Print the uninitialized warning now, so it includes the vari- - able name. */ - if (!SvOK(right)) { - if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); - sv_setsv_flags(left, &PL_sv_no, 0); - } - else sv_setsv_flags(left, right, 0); - SvGETMAGIC(right); + SV * const left = sv_newmortal(); + *(sp-1) = left; + /* Print the uninitialized warning now, so it includes the vari- + able name. */ + if (!SvOK(right)) { + if (ckWARN(WARN_UNINITIALIZED)) report_uninit(right); + sv_setsv_flags(left, &PL_sv_no, 0); + } + else sv_setsv_flags(left, right, 0); + SvGETMAGIC(right); } if (flags & AMGf_numeric) { - if (SvROK(TOPm1s)) - *(sp-1) = sv_2num(TOPm1s); - if (SvROK(right)) - *sp = sv_2num(right); + if (SvROK(TOPm1s)) + *(sp-1) = sv_2num(TOPm1s); + if (SvROK(right)) + *sp = sv_2num(right); } return FALSE; } @@ -3192,14 +3192,14 @@ Perl_amagic_deref_call(pTHX_ SV *ref, int method) { return ref; while ((tmpsv = amagic_call(ref, &PL_sv_undef, method, - AMGf_noright | AMGf_unary))) { - if (!SvROK(tmpsv)) - Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); - if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { - /* Bail out if it returns us the same reference. */ - return tmpsv; - } - ref = tmpsv; + AMGf_noright | AMGf_unary))) { + if (!SvROK(tmpsv)) + Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); + if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) { + /* Bail out if it returns us the same reference. */ + return tmpsv; + } + ref = tmpsv; if (!SvAMAGIC(ref)) break; } @@ -3214,19 +3214,19 @@ Perl_amagic_is_enabled(pTHX_ int method) assert(PL_curcop->cop_hints & HINT_NO_AMAGIC); if ( !lex_mask || !SvOK(lex_mask) ) - /* overloading lexically disabled */ - return FALSE; + /* overloading lexically disabled */ + return FALSE; else if ( lex_mask && SvPOK(lex_mask) ) { - /* we have an entry in the hints hash, check if method has been - * masked by overloading.pm */ - STRLEN len; - const int offset = method / 8; - const int bit = method % 8; - char *pv = SvPV(lex_mask, len); - - /* Bit set, so this overloading operator is disabled */ - if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) - return FALSE; + /* we have an entry in the hints hash, check if method has been + * masked by overloading.pm */ + STRLEN len; + const int offset = method / 8; + const int bit = method % 8; + char *pv = SvPV(lex_mask, len); + + /* Bit set, so this overloading operator is disabled */ + if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) + return FALSE; } return TRUE; } @@ -3259,16 +3259,16 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash) && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) - ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table - : NULL)) + ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table + : NULL)) && ((cv = cvp[off=method+assignshift]) - || (assign && amtp->fallback > AMGfallNEVER && /* fallback to - * usual method */ - ( + || (assign && amtp->fallback > AMGfallNEVER && /* fallback to + * usual method */ + ( #ifdef DEBUGGING - fl = 1, + fl = 1, #endif - cv = cvp[off=method])))) { + cv = cvp[off=method])))) { lr = -1; /* Call method for left argument */ } else { if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { @@ -3276,30 +3276,30 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) /* look for substituted methods */ /* In all the covered cases we should be called with assign==0. */ - switch (method) { - case inc_amg: - force_cpy = 1; - if ((cv = cvp[off=add_ass_amg]) - || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { - right = &PL_sv_yes; lr = -1; assign = 1; - } - break; - case dec_amg: - force_cpy = 1; - if ((cv = cvp[off = subtr_ass_amg]) - || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { - right = &PL_sv_yes; lr = -1; assign = 1; - } - break; - case bool__amg: - (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); - break; - case numer_amg: - (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); - break; - case string_amg: - (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); - break; + switch (method) { + case inc_amg: + force_cpy = 1; + if ((cv = cvp[off=add_ass_amg]) + || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { + right = &PL_sv_yes; lr = -1; assign = 1; + } + break; + case dec_amg: + force_cpy = 1; + if ((cv = cvp[off = subtr_ass_amg]) + || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { + right = &PL_sv_yes; lr = -1; assign = 1; + } + break; + case bool__amg: + (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); + break; + case numer_amg: + (void)((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])); + break; + case string_amg: + (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); + break; case not_amg: (void)((cv = cvp[off=bool__amg]) || (cv = cvp[off=numer_amg]) @@ -3307,115 +3307,115 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (cv) postpr = 1; break; - case copy_amg: - { - /* - * SV* ref causes confusion with the interpreter variable of - * the same name - */ - SV* const tmpRef=SvRV(left); - if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { - /* - * Just to be extra cautious. Maybe in some - * additional cases sv_setsv is safe, too. - */ - SV* const newref = newSVsv(tmpRef); - SvOBJECT_on(newref); - /* No need to do SvAMAGIC_on here, as SvAMAGIC macros - delegate to the stash. */ - SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); - return newref; - } - } - break; - case abs_amg: - if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) - && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { - SV* const nullsv=&PL_sv_zero; - if (off1==lt_amg) { - SV* const lessp = amagic_call(left,nullsv, - lt_amg,AMGf_noright); - logic = SvTRUE_NN(lessp); - } else { - SV* const lessp = amagic_call(left,nullsv, - ncmp_amg,AMGf_noright); - logic = (SvNV(lessp) < 0); - } - if (logic) { - if (off==subtr_amg) { - right = left; - left = nullsv; - lr = 1; - } - } else { - return left; - } - } - break; - case neg_amg: - if ((cv = cvp[off=subtr_amg])) { - right = left; - left = &PL_sv_zero; - lr = 1; - } - break; - case int_amg: - case iter_amg: /* XXXX Eventually should do to_gv. */ - case ftest_amg: /* XXXX Eventually should do to_gv. */ - case regexp_amg: - /* FAIL safe */ - return NULL; /* Delegate operation to standard mechanisms. */ - - case to_sv_amg: - case to_av_amg: - case to_hv_amg: - case to_gv_amg: - case to_cv_amg: - /* FAIL safe */ - return left; /* Delegate operation to standard mechanisms. */ - - default: - goto not_found; - } - if (!cv) goto not_found; + case copy_amg: + { + /* + * SV* ref causes confusion with the interpreter variable of + * the same name + */ + SV* const tmpRef=SvRV(left); + if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { + /* + * Just to be extra cautious. Maybe in some + * additional cases sv_setsv is safe, too. + */ + SV* const newref = newSVsv(tmpRef); + SvOBJECT_on(newref); + /* No need to do SvAMAGIC_on here, as SvAMAGIC macros + delegate to the stash. */ + SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); + return newref; + } + } + break; + case abs_amg: + if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) + && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { + SV* const nullsv=&PL_sv_zero; + if (off1==lt_amg) { + SV* const lessp = amagic_call(left,nullsv, + lt_amg,AMGf_noright); + logic = SvTRUE_NN(lessp); + } else { + SV* const lessp = amagic_call(left,nullsv, + ncmp_amg,AMGf_noright); + logic = (SvNV(lessp) < 0); + } + if (logic) { + if (off==subtr_amg) { + right = left; + left = nullsv; + lr = 1; + } + } else { + return left; + } + } + break; + case neg_amg: + if ((cv = cvp[off=subtr_amg])) { + right = left; + left = &PL_sv_zero; + lr = 1; + } + break; + case int_amg: + case iter_amg: /* XXXX Eventually should do to_gv. */ + case ftest_amg: /* XXXX Eventually should do to_gv. */ + case regexp_amg: + /* FAIL safe */ + return NULL; /* Delegate operation to standard mechanisms. */ + + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + /* FAIL safe */ + return left; /* Delegate operation to standard mechanisms. */ + + default: + goto not_found; + } + if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) - && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash) - && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) - && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) - ? (amtp = (AMT*)mg->mg_ptr)->table - : NULL)) - && (cv = cvp[off=method])) { /* Method for right - * argument found */ + && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash) + && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) + && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + ? (amtp = (AMT*)mg->mg_ptr)->table + : NULL)) + && (cv = cvp[off=method])) { /* Method for right + * argument found */ lr=1; } else if (((cvp && amtp->fallback > AMGfallNEVER) || (ocvp && oamtp->fallback > AMGfallNEVER)) - && !(flags & AMGf_unary)) { - /* We look for substitution for - * comparison operations and - * concatenation */ + && !(flags & AMGf_unary)) { + /* We look for substitution for + * comparison operations and + * concatenation */ if (method==concat_amg || method==concat_ass_amg - || method==repeat_amg || method==repeat_ass_amg) { - return NULL; /* Delegate operation to string conversion */ + || method==repeat_amg || method==repeat_ass_amg) { + return NULL; /* Delegate operation to string conversion */ } off = -1; switch (method) { - case lt_amg: - case le_amg: - case gt_amg: - case ge_amg: - case eq_amg: - case ne_amg: + case lt_amg: + case le_amg: + case gt_amg: + case ge_amg: + case eq_amg: + case ne_amg: off = ncmp_amg; break; - case slt_amg: - case sle_amg: - case sgt_amg: - case sge_amg: - case seq_amg: - case sne_amg: + case slt_amg: + case sle_amg: + case sgt_amg: + case sge_amg: + case seq_amg: + case sne_amg: off = scmp_amg; break; - } + } if (off != -1) { if (ocvp && (oamtp->fallback > AMGfallNEVER)) { cv = ocvp[off]; @@ -3433,51 +3433,51 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } else { not_found: /* No method found, either report or croak */ switch (method) { - case to_sv_amg: - case to_av_amg: - case to_hv_amg: - case to_gv_amg: - case to_cv_amg: - /* FAIL safe */ - return left; /* Delegate operation to standard mechanisms. */ + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + /* FAIL safe */ + return left; /* Delegate operation to standard mechanisms. */ } if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ - notfound = 1; lr = -1; + notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { - notfound = 1; lr = 1; + notfound = 1; lr = 1; } else if ((use_default_op = (!ocvp || oamtp->fallback >= AMGfallYES) && (!cvp || amtp->fallback >= AMGfallYES)) && !DEBUG_o_TEST) { - /* Skip generating the "no method found" message. */ - return NULL; + /* Skip generating the "no method found" message. */ + return NULL; } else { - SV *msg; - if (off==-1) off=method; - msg = sv_2mortal(Perl_newSVpvf(aTHX_ - "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf, - AMG_id2name(method + assignshift), - (flags & AMGf_unary ? " " : "\n\tleft "), - SvAMAGIC(left)? - "in overloaded package ": - "has no overloaded magic", - SvAMAGIC(left)? - SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))): - SVfARG(&PL_sv_no), - SvAMAGIC(right)? - ",\n\tright argument in overloaded package ": - (flags & AMGf_unary - ? "" - : ",\n\tright argument has no overloaded magic"), - SvAMAGIC(right)? - SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))): - SVfARG(&PL_sv_no))); + SV *msg; + if (off==-1) off=method; + msg = sv_2mortal(Perl_newSVpvf(aTHX_ + "Operation \"%s\": no method found,%sargument %s%" SVf "%s%" SVf, + AMG_id2name(method + assignshift), + (flags & AMGf_unary ? " " : "\n\tleft "), + SvAMAGIC(left)? + "in overloaded package ": + "has no overloaded magic", + SvAMAGIC(left)? + SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))): + SVfARG(&PL_sv_no), + SvAMAGIC(right)? + ",\n\tright argument in overloaded package ": + (flags & AMGf_unary + ? "" + : ",\n\tright argument has no overloaded magic"), + SvAMAGIC(right)? + SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))): + SVfARG(&PL_sv_no))); if (use_default_op) { - DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) ); - } else { - Perl_croak(aTHX_ "%" SVf, SVfARG(msg)); - } - return NULL; + DEBUG_o( Perl_deb(aTHX_ "%" SVf, SVfARG(msg)) ); + } else { + Perl_croak(aTHX_ "%" SVf, SVfARG(msg)); + } + return NULL; } force_cpy = force_cpy || assign; } @@ -3546,18 +3546,18 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) #ifdef DEBUGGING if (!notfound) { DEBUG_o(Perl_deb(aTHX_ - "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n", - AMG_id2name(off), - method+assignshift==off? "" : - " (initially \"", - method+assignshift==off? "" : - AMG_id2name(method+assignshift), - method+assignshift==off? "" : "\")", - flags & AMGf_unary? "" : - lr==1 ? " for right argument": " for left argument", - flags & AMGf_unary? " for argument" : "", - stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), - fl? ",\n\tassignment variant used": "") ); + "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %" SVf "%s\n", + AMG_id2name(off), + method+assignshift==off? "" : + " (initially \"", + method+assignshift==off? "" : + AMG_id2name(method+assignshift), + method+assignshift==off? "" : "\")", + flags & AMGf_unary? "" : + lr==1 ? " for right argument": " for left argument", + flags & AMGf_unary? " for argument" : "", + stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)), + fl? ",\n\tassignment variant used": "") ); } #endif /* Since we use shallow copy during assignment, we need @@ -3583,7 +3583,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) * In the latter case assignshift==0, so only notfound case is important. */ if ( (lr == -1) && ( ( (method + assignshift == off) - && (assign || (method == inc_amg) || (method == dec_amg))) + && (assign || (method == inc_amg) || (method == dec_amg))) || force_cpy) ) { /* newSVsv does not behave as advertised, so we copy missing @@ -3591,9 +3591,9 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SV *tmpRef = SvRV(left); SV *rv_copy; if (SvREFCNT(tmpRef) > 1 && (rv_copy = AMG_CALLunary(left,copy_amg))) { - SvRV_set(left, rv_copy); - SvSETMAGIC(left); - SvREFCNT_dec_NN(tmpRef); + SvRV_set(left, rv_copy); + SvSETMAGIC(left); + SvREFCNT_dec_NN(tmpRef); } } @@ -3636,7 +3636,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SAVEOP(); PL_op = (OP *) &myop; if (PERLDB_SUB && PL_curstash != PL_debstash) - PL_op->op_private |= OPpENTERSUB_DB; + PL_op->op_private |= OPpENTERSUB_DB; Perl_pp_pushmark(aTHX); EXTEND(SP, notfound + 5); @@ -3645,7 +3645,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), - AMG_id2namelen(method + assignshift), SVs_TEMP)); + AMG_id2namelen(method + assignshift), SVs_TEMP)); } else if (flags & AMGf_numarg) PUSHs(&PL_sv_undef); @@ -3692,34 +3692,34 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) switch (method) { case le_amg: case sle_amg: - ans=SvIV(res)<=0; break; + ans=SvIV(res)<=0; break; case lt_amg: case slt_amg: - ans=SvIV(res)<0; break; + ans=SvIV(res)<0; break; case ge_amg: case sge_amg: - ans=SvIV(res)>=0; break; + ans=SvIV(res)>=0; break; case gt_amg: case sgt_amg: - ans=SvIV(res)>0; break; + ans=SvIV(res)>0; break; case eq_amg: case seq_amg: - ans=SvIV(res)==0; break; + ans=SvIV(res)==0; break; case ne_amg: case sne_amg: - ans=SvIV(res)!=0; break; + ans=SvIV(res)!=0; break; case inc_amg: case dec_amg: - SvSetSV(left,res); return left; + SvSetSV(left,res); return left; case not_amg: - ans=!SvTRUE_NN(res); break; + ans=!SvTRUE_NN(res); break; default: ans=0; break; } return boolSV(ans); } else if (method==copy_amg) { if (!SvROK(res)) { - Perl_croak(aTHX_ "Copy method did not return a reference"); + Perl_croak(aTHX_ "Copy method did not return a reference"); } return SvREFCNT_inc(SvRV(res)); } else { @@ -3736,10 +3736,10 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) PERL_ARGS_ASSERT_GV_NAME_SET; if (len > I32_MAX) - Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len); + Perl_croak(aTHX_ "panic: gv name too long (%" UVuf ")", (UV) len); if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { - unshare_hek(GvNAME_HEK(gv)); + unshare_hek(GvNAME_HEK(gv)); } PERL_HASH(hash, name, len); @@ -3780,47 +3780,47 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) if (PL_phase == PERL_PHASE_DESTRUCT) return; if (!(SvREFCNT(gv) == 1 && SvTYPE(gv) == SVt_PVGV && !SvFAKE(gv) && - !SvOBJECT(gv) && !SvREADONLY(gv) && - isGV_with_GP(gv) && GvGP(gv) && - !GvINTRO(gv) && GvREFCNT(gv) == 1 && - !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && - GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) - return; + !SvOBJECT(gv) && !SvREADONLY(gv) && + isGV_with_GP(gv) && GvGP(gv) && + !GvINTRO(gv) && GvREFCNT(gv) == 1 && + !GvSV(gv) && !GvAV(gv) && !GvHV(gv) && !GvIOp(gv) && !GvFORM(gv) && + GvEGVx(gv) == gv && (stash = GvSTASH(gv)))) + return; if (gv == PL_statgv || gv == PL_last_in_gv || gv == PL_stderrgv) - return; + return; if (SvMAGICAL(gv)) { MAGIC *mg; - /* only backref magic is allowed */ - if (SvGMAGICAL(gv) || SvSMAGICAL(gv)) - return; + /* only backref magic is allowed */ + if (SvGMAGICAL(gv) || SvSMAGICAL(gv)) + return; for (mg = SvMAGIC(gv); mg; mg = mg->mg_moremagic) { if (mg->mg_type != PERL_MAGIC_backref) return; - } + } } cv = GvCV(gv); if (!cv) { - HEK *gvnhek = GvNAME_HEK(gv); - (void)hv_deletehek(stash, gvnhek, G_DISCARD); + HEK *gvnhek = GvNAME_HEK(gv); + (void)hv_deletehek(stash, gvnhek, G_DISCARD); } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 && - !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && - CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv && - CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && - !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && - (namehek = GvNAME_HEK(gv)) && - (gvp = hv_fetchhek(stash, namehek, 0)) && - *gvp == (SV*)gv) { - SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); - const bool imported = !!GvIMPORTED_CV(gv); - SvREFCNT(gv) = 0; - sv_clear((SV*)gv); - SvREFCNT(gv) = 1; - SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported; + !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && + CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv && + CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && + !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && + (namehek = GvNAME_HEK(gv)) && + (gvp = hv_fetchhek(stash, namehek, 0)) && + *gvp == (SV*)gv) { + SV *value = SvREFCNT_inc(CvXSUBANY(cv).any_ptr); + const bool imported = !!GvIMPORTED_CV(gv); + SvREFCNT(gv) = 0; + sv_clear((SV*)gv); + SvREFCNT(gv) = 1; + SvFLAGS(gv) = SVt_IV|SVf_ROK|SVprv_PCS_IMPORTED * imported; /* See also: 'SET_SVANY_FOR_BODYLESS_IV' in sv.c */ - SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - - STRUCT_OFFSET(XPVIV, xiv_iv)); - SvRV_set(gv, value); + SvANY(gv) = (XPVGV*)((char*)&(gv->sv_u.svu_iv) - + STRUCT_OFFSET(XPVIV, xiv_iv)); + SvRV_set(gv, value); } } @@ -3834,9 +3834,9 @@ Perl_gv_override(pTHX_ const char * const name, const STRLEN len) gvp = (GV**)hv_fetch(PL_globalstash, name, len, FALSE); gv = gvp ? *gvp : NULL; if (gv && !isGV(gv)) { - if (!SvPCS_IMPORTED(gv)) return NULL; - gv_init(gv, PL_globalstash, name, len, 0); - return gv; + if (!SvPCS_IMPORTED(gv)) return NULL; + gv_init(gv, PL_globalstash, name, len, 0); + return gv; } return gv && GvCVu(gv) && GvIMPORTED_CV(gv) ? gv : NULL; } @@ -28,32 +28,32 @@ struct gp { #if defined (DEBUGGING) && defined(PERL_USE_GCC_BRACE_GROUPS) && !defined(__INTEL_COMPILER) # define GvGP(gv) \ - (0+(*({GV *const _gvgp = (GV *) (gv); \ - assert(SvTYPE(_gvgp) == SVt_PVGV || SvTYPE(_gvgp) == SVt_PVLV); \ - assert(isGV_with_GP(_gvgp)); \ - &((_gvgp)->sv_u.svu_gp);}))) + (0+(*({GV *const _gvgp = (GV *) (gv); \ + assert(SvTYPE(_gvgp) == SVt_PVGV || SvTYPE(_gvgp) == SVt_PVLV); \ + assert(isGV_with_GP(_gvgp)); \ + &((_gvgp)->sv_u.svu_gp);}))) # define GvGP_set(gv,gp) \ - {GV *const _gvgp = (GV *) (gv); \ - assert(SvTYPE(_gvgp) == SVt_PVGV || SvTYPE(_gvgp) == SVt_PVLV); \ - assert(isGV_with_GP(_gvgp)); \ - (_gvgp)->sv_u.svu_gp = (gp); } + {GV *const _gvgp = (GV *) (gv); \ + assert(SvTYPE(_gvgp) == SVt_PVGV || SvTYPE(_gvgp) == SVt_PVLV); \ + assert(isGV_with_GP(_gvgp)); \ + (_gvgp)->sv_u.svu_gp = (gp); } # define GvFLAGS(gv) \ - (*({GV *const _gvflags = (GV *) (gv); \ - assert(SvTYPE(_gvflags) == SVt_PVGV || SvTYPE(_gvflags) == SVt_PVLV); \ - assert(isGV_with_GP(_gvflags)); \ - &(GvXPVGV(_gvflags)->xpv_cur);})) + (*({GV *const _gvflags = (GV *) (gv); \ + assert(SvTYPE(_gvflags) == SVt_PVGV || SvTYPE(_gvflags) == SVt_PVLV); \ + assert(isGV_with_GP(_gvflags)); \ + &(GvXPVGV(_gvflags)->xpv_cur);})) # define GvSTASH(gv) \ - (*({ GV * const _gvstash = (GV *) (gv); \ - assert(isGV_with_GP(_gvstash)); \ - assert(SvTYPE(_gvstash) == SVt_PVGV || SvTYPE(_gvstash) >= SVt_PVLV); \ - &(GvXPVGV(_gvstash)->xnv_u.xgv_stash); \ - })) + (*({ GV * const _gvstash = (GV *) (gv); \ + assert(isGV_with_GP(_gvstash)); \ + assert(SvTYPE(_gvstash) == SVt_PVGV || SvTYPE(_gvstash) >= SVt_PVLV); \ + &(GvXPVGV(_gvstash)->xnv_u.xgv_stash); \ + })) # define GvNAME_HEK(gv) \ (*({ GV * const _gvname_hek = (GV *) (gv); \ - assert(isGV_with_GP(_gvname_hek)); \ - assert(SvTYPE(_gvname_hek) == SVt_PVGV || SvTYPE(_gvname_hek) >= SVt_PVLV); \ - &(GvXPVGV(_gvname_hek)->xiv_u.xivu_namehek); \ - })) + assert(isGV_with_GP(_gvname_hek)); \ + assert(SvTYPE(_gvname_hek) == SVt_PVGV || SvTYPE(_gvname_hek) >= SVt_PVLV); \ + &(GvXPVGV(_gvname_hek)->xiv_u.xivu_namehek); \ + })) # define GvNAME_get(gv) ({ assert(GvNAME_HEK(gv)); (char *)HEK_KEY(GvNAME_HEK(gv)); }) # define GvNAMELEN_get(gv) ({ assert(GvNAME_HEK(gv)); HEK_LEN(GvNAME_HEK(gv)); }) # define GvNAMEUTF8(gv) ({ assert(GvNAME_HEK(gv)); HEK_UTF8(GvNAME_HEK(gv)); }) @@ -101,8 +101,8 @@ Return the CV from the GV. #define GvSV(gv) (GvGP(gv)->gp_sv) #ifdef PERL_DONT_CREATE_GVSV #define GvSVn(gv) (*(GvGP(gv)->gp_sv ? \ - &(GvGP(gv)->gp_sv) : \ - &(GvGP(gv_SVadd(gv))->gp_sv))) + &(GvGP(gv)->gp_sv) : \ + &(GvGP(gv_SVadd(gv))->gp_sv))) #else #define GvSVn(gv) GvSV(gv) #endif @@ -126,13 +126,13 @@ Return the CV from the GV. #define GvAV(gv) (GvGP(gv)->gp_av) #define GvAVn(gv) (GvGP(gv)->gp_av ? \ - GvGP(gv)->gp_av : \ - GvGP(gv_AVadd(gv))->gp_av) + GvGP(gv)->gp_av : \ + GvGP(gv_AVadd(gv))->gp_av) #define GvHV(gv) ((GvGP(gv))->gp_hv) #define GvHVn(gv) (GvGP(gv)->gp_hv ? \ - GvGP(gv)->gp_hv : \ - GvGP(gv_HVadd(gv))->gp_hv) + GvGP(gv)->gp_hv : \ + GvGP(gv_HVadd(gv))->gp_hv) #define GvCV(gv) (0+GvGP(gv)->gp_cv) #define GvCV_set(gv,cv) (GvGP(gv)->gp_cv = (cv)) @@ -221,27 +221,27 @@ Return the CV from the GV. * symbol creation flags, for use in gv_fetchpv() and get_*v() */ #define GV_ADD 0x01 /* add, if symbol not already there - For gv_name_set, adding a HEK for the first - time, so don't try to free what's there. */ + For gv_name_set, adding a HEK for the first + time, so don't try to free what's there. */ #define GV_ADDMULTI 0x02 /* add, pretending it has been added - already; used also by gv_init_* */ + already; used also by gv_init_* */ #define GV_ADDWARN 0x04 /* add, but warn if symbol wasn't already there */ - /* 0x08 UNUSED */ + /* 0x08 UNUSED */ #define GV_NOINIT 0x10 /* add, but don't init symbol, if type != PVGV */ /* This is used by toke.c to avoid turing placeholder constants in the symbol table into full PVGVs with attached constant subroutines. */ #define GV_NOADD_NOINIT 0x20 /* Don't add the symbol if it's not there. - Don't init it if it is there but ! PVGV */ + Don't init it if it is there but ! PVGV */ #define GV_NOEXPAND 0x40 /* Don't expand SvOK() entries to PVGV */ #define GV_NOTQUAL 0x80 /* A plain symbol name, not qualified with a - package (so skip checks for :: and ') */ + package (so skip checks for :: and ') */ #define GV_AUTOLOAD 0x100 /* gv_fetchmethod_flags() should AUTOLOAD */ #define GV_CROAK 0x200 /* gv_fetchmethod_flags() should croak */ #define GV_ADDMG 0x400 /* add if magical */ #define GV_NO_SVGMAGIC 0x800 /* Skip get-magic on an SV argument; - used only by gv_fetchsv(_nomg) */ + used only by gv_fetchsv(_nomg) */ #define GV_CACHE_ONLY 0x1000 /* return stash only if found in cache; - used only in flags parameter to gv_stash* family */ + used only in flags parameter to gv_stash* family */ /* Flags for gv_fetchmeth_pvn and gv_autoload_pvn*/ #define GV_SUPER 0x1000 /* SUPER::method */ @@ -250,8 +250,8 @@ Return the CV from the GV. #define GV_AUTOLOAD_ISMETHOD 1 /* autoloading a method? */ /* SVf_UTF8 (more accurately the return value from SvUTF8) is also valid - as a flag to various gv_* functions, so ensure it lies - outside this range. + as a flag to various gv_* functions, so ensure it lies + outside this range. */ #define GV_NOADD_MASK \ @@ -265,7 +265,7 @@ Return the CV from the GV. #define gv_fetchmethod(stash, name) gv_fetchmethod_autoload(stash, name, TRUE) #define gv_fetchsv_nomg(n,f,t) gv_fetchsv(n,(f)|GV_NO_SVGMAGIC,t) #define gv_init(gv,stash,name,len,multi) \ - gv_init_pvn(gv,stash,name,len,GV_ADDMULTI*!!(multi)) + gv_init_pvn(gv,stash,name,len,GV_ADDMULTI*!!(multi)) #define gv_fetchmeth(stash,name,len,level) gv_fetchmeth_pvn(stash, name, len, level, 0) #define gv_fetchmeth_autoload(stash,name,len,level) gv_fetchmeth_pvn_autoload(stash, name, len, level, 0) #define gv_fetchmethod_flags(stash,name,flags) gv_fetchmethod_pv_flags(stash, name, flags) @@ -277,14 +277,14 @@ Equivalent to C<L</gv_autoload_pvn>>. =cut */ #define gv_autoload4(stash, name, len, autoload) \ - gv_autoload_pvn(stash, name, len, !!(autoload)) + gv_autoload_pvn(stash, name, len, !!(autoload)) #define newGVgen(pack) newGVgen_flags(pack, 0) #define gv_method_changed(gv) \ ( \ - assert_(isGV_with_GP(gv)) \ - GvREFCNT(gv) > 1 \ - ? (void)++PL_sub_generation \ - : mro_method_changed_in(GvSTASH(gv)) \ + assert_(isGV_with_GP(gv)) \ + GvREFCNT(gv) > 1 \ + ? (void)++PL_sub_generation \ + : mro_method_changed_in(GvSTASH(gv)) \ ) #define gv_AVadd(gv) gv_add_by_type((gv), SVt_PVAV) @@ -183,13 +183,13 @@ C<(bool)!!(cbool)> in a ternary triggers a bug in xlc on AIX For dealing with issues that may arise from various 32/64-bit systems, we will ask Configure to check out - SHORTSIZE == sizeof(short) - INTSIZE == sizeof(int) - LONGSIZE == sizeof(long) - LONGLONGSIZE == sizeof(long long) (if HAS_LONG_LONG) - PTRSIZE == sizeof(void *) - DOUBLESIZE == sizeof(double) - LONG_DOUBLESIZE == sizeof(long double) (if HAS_LONG_DOUBLE). + SHORTSIZE == sizeof(short) + INTSIZE == sizeof(int) + LONGSIZE == sizeof(long) + LONGLONGSIZE == sizeof(long long) (if HAS_LONG_LONG) + PTRSIZE == sizeof(void *) + DOUBLESIZE == sizeof(double) + LONG_DOUBLESIZE == sizeof(long double) (if HAS_LONG_DOUBLE). */ @@ -494,7 +494,7 @@ Perl_xxx(aTHX_ ...) form for any API calls where it's used. #define lex_stuff_pvs(pv,flags) Perl_lex_stuff_pvn(aTHX_ STR_WITH_LEN(pv), flags) #define get_cvs(str, flags) \ - Perl_get_cvn_flags(aTHX_ STR_WITH_LEN(str), (flags)) + Perl_get_cvn_flags(aTHX_ STR_WITH_LEN(str), (flags)) /* internal helpers */ /* Transitional */ @@ -2442,16 +2442,16 @@ typedef U32 line_t; /* Helpful alias for version prescan */ #define is_LAX_VERSION(a,b) \ - (a != Perl_prescan_version(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL)) + (a != Perl_prescan_version(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL)) #define is_STRICT_VERSION(a,b) \ - (a != Perl_prescan_version(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL)) + (a != Perl_prescan_version(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL)) #define BADVERSION(a,b,c) \ - if (b) { \ - *b = c; \ - } \ - return a; + if (b) { \ + *b = c; \ + } \ + return a; /* Converts a character KNOWN to represent a hexadecimal digit (0-9, A-F, or * a-f) to its numeric value without using any branches. The input is @@ -2639,17 +2639,17 @@ PoisonWith(0xEF) for catching access to freed memory. MEM_SIZE_MAX/sizeof(t)) > MEM_SIZE_MAX/sizeof(t)) # define MEM_WRAP_CHECK(n,t) \ - (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ + (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ && (croak_memory_wrap(),0)) # define MEM_WRAP_CHECK_1(n,t,a) \ - (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ - && (Perl_croak_nocontext("%s",(a)),0)) + (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ + && (Perl_croak_nocontext("%s",(a)),0)) /* "a" arg must be a string literal */ # define MEM_WRAP_CHECK_s(n,t,a) \ - (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ - && (Perl_croak_nocontext("" a ""),0)) + (void)(UNLIKELY(_MEM_WRAP_WILL_WRAP(n,t)) \ + && (Perl_croak_nocontext("" a ""),0)) #define MEM_WRAP_CHECK_(n,t) MEM_WRAP_CHECK(n,t), @@ -2744,9 +2744,9 @@ void Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumbe #endif #define Renew(v,n,t) \ - (v = (MEM_WRAP_CHECK_(n,t) (t*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))))) + (v = (MEM_WRAP_CHECK_(n,t) (t*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))))) #define Renewc(v,n,t,c) \ - (v = (MEM_WRAP_CHECK_(n,t) (c*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))))) + (v = (MEM_WRAP_CHECK_(n,t) (c*)MEM_LOG_REALLOC(n,t,v,saferealloc((Malloc_t)(v),(MEM_SIZE)((n)*sizeof(t)))))) #ifdef PERL_POISON #define Safefree(d) \ diff --git a/hints/t001.c b/hints/t001.c index 562d7597ff..5edb855384 100644 --- a/hints/t001.c +++ b/hints/t001.c @@ -21,70 +21,70 @@ void test(double *result) { - float afloat; - double adouble; - int checksum = 0; - unsigned cuv = 0; - double cdouble = 0.0; - const int bits_in_uv = 8 * sizeof(cuv); + float afloat; + double adouble; + int checksum = 0; + unsigned cuv = 0; + double cdouble = 0.0; + const int bits_in_uv = 8 * sizeof(cuv); - checksum = 53; - cdouble = -1.0; + checksum = 53; + cdouble = -1.0; - if (checksum) { - if (checksum > bits_in_uv) { - double trouble; + if (checksum) { + if (checksum > bits_in_uv) { + double trouble; - adouble = (double) (1 << (checksum & 15)); + adouble = (double) (1 << (checksum & 15)); - while (checksum >= 16) { - checksum -= 16; - adouble *= 65536.0; - } + while (checksum >= 16) { + checksum -= 16; + adouble *= 65536.0; + } - /* At -O1, GCC 2.95.2 compiles the following loop - into: + /* At -O1, GCC 2.95.2 compiles the following loop + into: - L$0014 - fcmp,dbl,>= %fr4,%fr0 - ftest - b L$0014 - fadd,dbl %fr4,%fr12,%fr4 - fsub,dbl %fr4,%fr12,%fr4 + L$0014 + fcmp,dbl,>= %fr4,%fr0 + ftest + b L$0014 + fadd,dbl %fr4,%fr12,%fr4 + fsub,dbl %fr4,%fr12,%fr4 - This code depends on the floating-add and - floating-subtract retaining all of the - precision present in the operands. There is - no such guarantee when using floating-point, - as this test case demonstrates. + This code depends on the floating-add and + floating-subtract retaining all of the + precision present in the operands. There is + no such guarantee when using floating-point, + as this test case demonstrates. - The code is okay at -O0. */ + The code is okay at -O0. */ - while (cdouble < 0.0) - cdouble += adouble; + while (cdouble < 0.0) + cdouble += adouble; - cdouble = modf (cdouble / adouble, &trouble) * adouble; - } - } + cdouble = modf (cdouble / adouble, &trouble) * adouble; + } + } - *result = cdouble; + *result = cdouble; } int main (int argc, char ** argv) { double value; - test (&value); + test (&value); - if (argc == 2 && !strcmp(argv[1],"-v")) - printf ("value = %.18e\n", value); + if (argc == 2 && !strcmp(argv[1],"-v")) + printf ("value = %.18e\n", value); - if (value != 9.007199254740991e+15) { - printf ("t001 fails!\n"); - return -1; - } - else { - printf ("t001 works.\n"); - return 0; - } + if (value != 9.007199254740991e+15) { + printf ("t001 fails!\n"); + return -1; + } + else { + printf ("t001 works.\n"); + return 0; + } } @@ -57,7 +57,7 @@ S_new_he(pTHX) void ** const root = &PL_body_roots[HE_SVSLOT]; if (!*root) - Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE); + Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE); he = (HE*) *root; assert(he); *root = HeNEXT(he); @@ -67,8 +67,8 @@ S_new_he(pTHX) #define new_HE() new_he() #define del_HE(p) \ STMT_START { \ - HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \ - PL_body_roots[HE_SVSLOT] = p; \ + HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \ + PL_body_roots[HE_SVSLOT] = p; \ } STMT_END @@ -93,7 +93,7 @@ S_save_hek_flags(const char *str, I32 len, U32 hash, int flags) HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED; if (flags & HVhek_FREEKEY) - Safefree(str); + Safefree(str); return hek; } @@ -105,10 +105,10 @@ Perl_free_tied_hv_pool(pTHX) { HE *he = PL_hv_fetch_ent_mh; while (he) { - HE * const ohe = he; - Safefree(HeKEY_hek(he)); - he = HeNEXT(he); - del_HE(ohe); + HE * const ohe = he; + Safefree(HeKEY_hek(he)); + he = HeNEXT(he); + del_HE(ohe); } PL_hv_fetch_ent_mh = NULL; } @@ -123,18 +123,18 @@ Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param) PERL_UNUSED_ARG(param); if (!source) - return NULL; + return NULL; shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); if (shared) { - /* We already shared this hash key. */ - (void)share_hek_hek(shared); + /* We already shared this hash key. */ + (void)share_hek_hek(shared); } else { - shared - = share_hek_flags(HEK_KEY(source), HEK_LEN(source), - HEK_HASH(source), HEK_FLAGS(source)); - ptr_table_store(PL_ptr_table, source, shared); + shared + = share_hek_flags(HEK_KEY(source), HEK_LEN(source), + HEK_HASH(source), HEK_FLAGS(source)); + ptr_table_store(PL_ptr_table, source, shared); } return shared; } @@ -147,11 +147,11 @@ Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) PERL_ARGS_ASSERT_HE_DUP; if (!e) - return NULL; + return NULL; /* look for it in the table first */ ret = (HE*)ptr_table_fetch(PL_ptr_table, e); if (ret) - return ret; + return ret; /* create anew and remember what it is */ ret = new_HE(); @@ -159,31 +159,31 @@ Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) HeNEXT(ret) = he_dup(HeNEXT(e),shared, param); if (HeKLEN(e) == HEf_SVKEY) { - char *k; - Newx(k, HEK_BASESIZE + sizeof(const SV *), char); - HeKEY_hek(ret) = (HEK*)k; - HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param); + char *k; + Newx(k, HEK_BASESIZE + sizeof(const SV *), char); + HeKEY_hek(ret) = (HEK*)k; + HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param); } else if (shared) { - /* This is hek_dup inlined, which seems to be important for speed - reasons. */ - HEK * const source = HeKEY_hek(e); - HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); - - if (shared) { - /* We already shared this hash key. */ - (void)share_hek_hek(shared); - } - else { - shared - = share_hek_flags(HEK_KEY(source), HEK_LEN(source), - HEK_HASH(source), HEK_FLAGS(source)); - ptr_table_store(PL_ptr_table, source, shared); - } - HeKEY_hek(ret) = shared; + /* This is hek_dup inlined, which seems to be important for speed + reasons. */ + HEK * const source = HeKEY_hek(e); + HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source); + + if (shared) { + /* We already shared this hash key. */ + (void)share_hek_hek(shared); + } + else { + shared + = share_hek_flags(HEK_KEY(source), HEK_LEN(source), + HEK_HASH(source), HEK_FLAGS(source)); + ptr_table_store(PL_ptr_table, source, shared); + } + HeKEY_hek(ret) = shared; } else - HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), + HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), HeKFLAGS(e)); HeVAL(ret) = sv_dup_inc(HeVAL(e), param); return ret; @@ -192,22 +192,22 @@ Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param) static void S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, - const char *msg) + const char *msg) { SV * const sv = sv_newmortal(); PERL_ARGS_ASSERT_HV_NOTALLOWED; if (!(flags & HVhek_FREEKEY)) { - sv_setpvn(sv, key, klen); + sv_setpvn(sv, key, klen); } else { - /* Need to free saved eventually assign to mortal SV */ - /* XXX is this line an error ???: SV *sv = sv_newmortal(); */ - sv_usepvn(sv, (char *) key, klen); + /* Need to free saved eventually assign to mortal SV */ + /* XXX is this line an error ???: SV *sv = sv_newmortal(); */ + sv_usepvn(sv, (char *) key, klen); } if (flags & HVhek_UTF8) { - SvUTF8_on(sv); + SvUTF8_on(sv); } Perl_croak(aTHX_ msg, SVfARG(sv)); } @@ -321,7 +321,7 @@ information on how to use this function on tied hashes. /* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store() */ void * Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32, - const int action, SV *val, const U32 hash) + const int action, SV *val, const U32 hash) { STRLEN klen; int flags; @@ -329,18 +329,18 @@ Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32, PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN; if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; + klen = -klen_i32; + flags = HVhek_UTF8; } else { - klen = klen_i32; - flags = 0; + klen = klen_i32; + flags = 0; } return hv_common(hv, NULL, key, klen, flags, action, val, hash); } void * Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, - int flags, int action, SV *val, U32 hash) + int flags, int action, SV *val, U32 hash) { XPVHV* xhv; HE *entry; @@ -353,276 +353,276 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, HEK *keysv_hek = NULL; if (!hv) - return NULL; + return NULL; if (SvTYPE(hv) == (svtype)SVTYPEMASK) - return NULL; + return NULL; assert(SvTYPE(hv) == SVt_PVHV); if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) { - MAGIC* mg; - if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) { - struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; - if (uf->uf_set == NULL) { - SV* obj = mg->mg_obj; - - if (!keysv) { - keysv = newSVpvn_flags(key, klen, SVs_TEMP | - ((flags & HVhek_UTF8) - ? SVf_UTF8 : 0)); - } - - mg->mg_obj = keysv; /* pass key */ - uf->uf_index = action; /* pass action */ - magic_getuvar(MUTABLE_SV(hv), mg); - keysv = mg->mg_obj; /* may have changed */ - mg->mg_obj = obj; - - /* If the key may have changed, then we need to invalidate - any passed-in computed hash value. */ - hash = 0; - } - } + MAGIC* mg; + if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) { + struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; + if (uf->uf_set == NULL) { + SV* obj = mg->mg_obj; + + if (!keysv) { + keysv = newSVpvn_flags(key, klen, SVs_TEMP | + ((flags & HVhek_UTF8) + ? SVf_UTF8 : 0)); + } + + mg->mg_obj = keysv; /* pass key */ + uf->uf_index = action; /* pass action */ + magic_getuvar(MUTABLE_SV(hv), mg); + keysv = mg->mg_obj; /* may have changed */ + mg->mg_obj = obj; + + /* If the key may have changed, then we need to invalidate + any passed-in computed hash value. */ + hash = 0; + } + } } if (keysv) { - if (flags & HVhek_FREEKEY) - Safefree(key); - key = SvPV_const(keysv, klen); - is_utf8 = (SvUTF8(keysv) != 0); - if (SvIsCOW_shared_hash(keysv)) { - flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0); - } else { - flags = 0; - } + if (flags & HVhek_FREEKEY) + Safefree(key); + key = SvPV_const(keysv, klen); + is_utf8 = (SvUTF8(keysv) != 0); + if (SvIsCOW_shared_hash(keysv)) { + flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0); + } else { + flags = 0; + } } else { - is_utf8 = cBOOL(flags & HVhek_UTF8); + is_utf8 = cBOOL(flags & HVhek_UTF8); } if (action & HV_DELETE) { - return (void *) hv_delete_common(hv, keysv, key, klen, - flags | (is_utf8 ? HVhek_UTF8 : 0), - action, hash); + return (void *) hv_delete_common(hv, keysv, key, klen, + flags | (is_utf8 ? HVhek_UTF8 : 0), + action, hash); } xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { - if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) { - if (mg_find((const SV *)hv, PERL_MAGIC_tied) - || SvGMAGICAL((const SV *)hv)) - { - /* FIXME should be able to skimp on the HE/HEK here when - HV_FETCH_JUST_SV is true. */ - if (!keysv) { - keysv = newSVpvn_utf8(key, klen, is_utf8); - } else { - keysv = newSVsv(keysv); - } + if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) { + if (mg_find((const SV *)hv, PERL_MAGIC_tied) + || SvGMAGICAL((const SV *)hv)) + { + /* FIXME should be able to skimp on the HE/HEK here when + HV_FETCH_JUST_SV is true. */ + if (!keysv) { + keysv = newSVpvn_utf8(key, klen, is_utf8); + } else { + keysv = newSVsv(keysv); + } sv = sv_newmortal(); mg_copy(MUTABLE_SV(hv), sv, (char *)keysv, HEf_SVKEY); - /* grab a fake HE/HEK pair from the pool or make a new one */ - entry = PL_hv_fetch_ent_mh; - if (entry) - PL_hv_fetch_ent_mh = HeNEXT(entry); - else { - char *k; - entry = new_HE(); - Newx(k, HEK_BASESIZE + sizeof(const SV *), char); - HeKEY_hek(entry) = (HEK*)k; - } - HeNEXT(entry) = NULL; - HeSVKEY_set(entry, keysv); - HeVAL(entry) = sv; - sv_upgrade(sv, SVt_PVLV); - LvTYPE(sv) = 'T'; - /* so we can free entry when freeing sv */ - LvTARG(sv) = MUTABLE_SV(entry); - - /* XXX remove at some point? */ - if (flags & HVhek_FREEKEY) - Safefree(key); - - if (return_svp) { - return entry ? (void *) &HeVAL(entry) : NULL; - } - return (void *) entry; - } + /* grab a fake HE/HEK pair from the pool or make a new one */ + entry = PL_hv_fetch_ent_mh; + if (entry) + PL_hv_fetch_ent_mh = HeNEXT(entry); + else { + char *k; + entry = new_HE(); + Newx(k, HEK_BASESIZE + sizeof(const SV *), char); + HeKEY_hek(entry) = (HEK*)k; + } + HeNEXT(entry) = NULL; + HeSVKEY_set(entry, keysv); + HeVAL(entry) = sv; + sv_upgrade(sv, SVt_PVLV); + LvTYPE(sv) = 'T'; + /* so we can free entry when freeing sv */ + LvTARG(sv) = MUTABLE_SV(entry); + + /* XXX remove at some point? */ + if (flags & HVhek_FREEKEY) + Safefree(key); + + if (return_svp) { + return entry ? (void *) &HeVAL(entry) : NULL; + } + return (void *) entry; + } #ifdef ENV_IS_CASELESS - else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { - U32 i; - for (i = 0; i < klen; ++i) - if (isLOWER(key[i])) { - /* Would be nice if we had a routine to do the - copy and upercase in a single pass through. */ - const char * const nkey = strupr(savepvn(key,klen)); - /* Note that this fetch is for nkey (the uppercased - key) whereas the store is for key (the original) */ - void *result = hv_common(hv, NULL, nkey, klen, - HVhek_FREEKEY, /* free nkey */ - 0 /* non-LVAL fetch */ - | HV_DISABLE_UVAR_XKEY - | return_svp, - NULL /* no value */, - 0 /* compute hash */); - if (!result && (action & HV_FETCH_LVALUE)) { - /* This call will free key if necessary. - Do it this way to encourage compiler to tail - call optimise. */ - result = hv_common(hv, keysv, key, klen, flags, - HV_FETCH_ISSTORE - | HV_DISABLE_UVAR_XKEY - | return_svp, - newSV(0), hash); - } else { - if (flags & HVhek_FREEKEY) - Safefree(key); - } - return result; - } - } + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { + U32 i; + for (i = 0; i < klen; ++i) + if (isLOWER(key[i])) { + /* Would be nice if we had a routine to do the + copy and upercase in a single pass through. */ + const char * const nkey = strupr(savepvn(key,klen)); + /* Note that this fetch is for nkey (the uppercased + key) whereas the store is for key (the original) */ + void *result = hv_common(hv, NULL, nkey, klen, + HVhek_FREEKEY, /* free nkey */ + 0 /* non-LVAL fetch */ + | HV_DISABLE_UVAR_XKEY + | return_svp, + NULL /* no value */, + 0 /* compute hash */); + if (!result && (action & HV_FETCH_LVALUE)) { + /* This call will free key if necessary. + Do it this way to encourage compiler to tail + call optimise. */ + result = hv_common(hv, keysv, key, klen, flags, + HV_FETCH_ISSTORE + | HV_DISABLE_UVAR_XKEY + | return_svp, + newSV(0), hash); + } else { + if (flags & HVhek_FREEKEY) + Safefree(key); + } + return result; + } + } #endif - } /* ISFETCH */ - else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) { - if (mg_find((const SV *)hv, PERL_MAGIC_tied) - || SvGMAGICAL((const SV *)hv)) { - /* I don't understand why hv_exists_ent has svret and sv, - whereas hv_exists only had one. */ - SV * const svret = sv_newmortal(); - sv = sv_newmortal(); - - if (keysv || is_utf8) { - if (!keysv) { - keysv = newSVpvn_utf8(key, klen, TRUE); - } else { - keysv = newSVsv(keysv); - } - mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY); - } else { - mg_copy(MUTABLE_SV(hv), sv, key, klen); - } - if (flags & HVhek_FREEKEY) - Safefree(key); - { + } /* ISFETCH */ + else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) { + if (mg_find((const SV *)hv, PERL_MAGIC_tied) + || SvGMAGICAL((const SV *)hv)) { + /* I don't understand why hv_exists_ent has svret and sv, + whereas hv_exists only had one. */ + SV * const svret = sv_newmortal(); + sv = sv_newmortal(); + + if (keysv || is_utf8) { + if (!keysv) { + keysv = newSVpvn_utf8(key, klen, TRUE); + } else { + keysv = newSVsv(keysv); + } + mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY); + } else { + mg_copy(MUTABLE_SV(hv), sv, key, klen); + } + if (flags & HVhek_FREEKEY) + Safefree(key); + { MAGIC * const mg = mg_find(sv, PERL_MAGIC_tiedelem); if (mg) magic_existspack(svret, mg); - } - /* This cast somewhat evil, but I'm merely using NULL/ - not NULL to return the boolean exists. - And I know hv is not NULL. */ - return SvTRUE_NN(svret) ? (void *)hv : NULL; - } + } + /* This cast somewhat evil, but I'm merely using NULL/ + not NULL to return the boolean exists. + And I know hv is not NULL. */ + return SvTRUE_NN(svret) ? (void *)hv : NULL; + } #ifdef ENV_IS_CASELESS - else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { - /* XXX This code isn't UTF8 clean. */ - char * const keysave = (char * const)key; - /* Will need to free this, so set FREEKEY flag. */ - key = savepvn(key,klen); - key = (const char*)strupr((char*)key); - is_utf8 = FALSE; - hash = 0; - keysv = 0; - - if (flags & HVhek_FREEKEY) { - Safefree(keysave); - } - flags |= HVhek_FREEKEY; - } + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { + /* XXX This code isn't UTF8 clean. */ + char * const keysave = (char * const)key; + /* Will need to free this, so set FREEKEY flag. */ + key = savepvn(key,klen); + key = (const char*)strupr((char*)key); + is_utf8 = FALSE; + hash = 0; + keysv = 0; + + if (flags & HVhek_FREEKEY) { + Safefree(keysave); + } + flags |= HVhek_FREEKEY; + } #endif - } /* ISEXISTS */ - else if (action & HV_FETCH_ISSTORE) { - bool needs_copy; - bool needs_store; - hv_magic_check (hv, &needs_copy, &needs_store); - if (needs_copy) { - const bool save_taint = TAINT_get; - if (keysv || is_utf8) { - if (!keysv) { - keysv = newSVpvn_utf8(key, klen, TRUE); - } - if (TAINTING_get) - TAINT_set(SvTAINTED(keysv)); - keysv = sv_2mortal(newSVsv(keysv)); - mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY); - } else { - mg_copy(MUTABLE_SV(hv), val, key, klen); - } - - TAINT_IF(save_taint); + } /* ISEXISTS */ + else if (action & HV_FETCH_ISSTORE) { + bool needs_copy; + bool needs_store; + hv_magic_check (hv, &needs_copy, &needs_store); + if (needs_copy) { + const bool save_taint = TAINT_get; + if (keysv || is_utf8) { + if (!keysv) { + keysv = newSVpvn_utf8(key, klen, TRUE); + } + if (TAINTING_get) + TAINT_set(SvTAINTED(keysv)); + keysv = sv_2mortal(newSVsv(keysv)); + mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY); + } else { + mg_copy(MUTABLE_SV(hv), val, key, klen); + } + + TAINT_IF(save_taint); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(save_taint); #endif - if (!needs_store) { - if (flags & HVhek_FREEKEY) - Safefree(key); - return NULL; - } + if (!needs_store) { + if (flags & HVhek_FREEKEY) + Safefree(key); + return NULL; + } #ifdef ENV_IS_CASELESS - else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { - /* XXX This code isn't UTF8 clean. */ - const char *keysave = key; - /* Will need to free this, so set FREEKEY flag. */ - key = savepvn(key,klen); - key = (const char*)strupr((char*)key); - is_utf8 = FALSE; - hash = 0; - keysv = 0; - - if (flags & HVhek_FREEKEY) { - Safefree(keysave); - } - flags |= HVhek_FREEKEY; - } + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { + /* XXX This code isn't UTF8 clean. */ + const char *keysave = key; + /* Will need to free this, so set FREEKEY flag. */ + key = savepvn(key,klen); + key = (const char*)strupr((char*)key); + is_utf8 = FALSE; + hash = 0; + keysv = 0; + + if (flags & HVhek_FREEKEY) { + Safefree(keysave); + } + flags |= HVhek_FREEKEY; + } #endif - } - } /* ISSTORE */ + } + } /* ISSTORE */ } /* SvMAGICAL */ if (!HvARRAY(hv)) { - if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE)) + if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE)) #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ - || (SvRMAGICAL((const SV *)hv) - && mg_find((const SV *)hv, PERL_MAGIC_env)) + || (SvRMAGICAL((const SV *)hv) + && mg_find((const SV *)hv, PERL_MAGIC_env)) #endif - ) { - char *array; - Newxz(array, - PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), - char); - HvARRAY(hv) = (HE**)array; - } + ) { + char *array; + Newxz(array, + PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), + char); + HvARRAY(hv) = (HE**)array; + } #ifdef DYNAMIC_ENV_FETCH - else if (action & HV_FETCH_ISEXISTS) { - /* for an %ENV exists, if we do an insert it's by a recursive - store call, so avoid creating HvARRAY(hv) right now. */ - } + else if (action & HV_FETCH_ISEXISTS) { + /* for an %ENV exists, if we do an insert it's by a recursive + store call, so avoid creating HvARRAY(hv) right now. */ + } #endif - else { - /* XXX remove at some point? */ + else { + /* XXX remove at some point? */ if (flags & HVhek_FREEKEY) Safefree(key); - return NULL; - } + return NULL; + } } if (is_utf8 && !(flags & HVhek_KEYCANONICAL)) { - char * const keysave = (char *)key; - key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); + char * const keysave = (char *)key; + key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); if (is_utf8) - flags |= HVhek_UTF8; - else - flags &= ~HVhek_UTF8; + flags |= HVhek_UTF8; + else + flags &= ~HVhek_UTF8; if (key != keysave) { - if (flags & HVhek_FREEKEY) - Safefree(keysave); + if (flags & HVhek_FREEKEY) + Safefree(keysave); flags |= HVhek_WASUTF8 | HVhek_FREEKEY; - /* If the caller calculated a hash, it was on the sequence of - octets that are the UTF-8 form. We've now changed the sequence - of octets stored to that of the equivalent byte representation, - so the hash we need is different. */ - hash = 0; - } + /* If the caller calculated a hash, it was on the sequence of + octets that are the UTF-8 form. We've now changed the sequence + of octets stored to that of the equivalent byte representation, + so the hash we need is different. */ + hash = 0; + } } if (keysv && (SvIsCOW_shared_hash(keysv))) { @@ -640,7 +640,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, else #endif { - entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; + entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; } if (!entry) @@ -674,146 +674,146 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } for (; entry; entry = HeNEXT(entry)) { - if (HeHASH(entry) != hash) /* strings can't be equal */ - continue; - if (HeKLEN(entry) != (I32)klen) - continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ - continue; - if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) - continue; + if (HeHASH(entry) != hash) /* strings can't be equal */ + continue; + if (HeKLEN(entry) != (I32)klen) + continue; + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + continue; + if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) + continue; found: if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) { - if (HeKFLAGS(entry) != masked_flags) { - /* We match if HVhek_UTF8 bit in our flags and hash key's - match. But if entry was set previously with HVhek_WASUTF8 - and key now doesn't (or vice versa) then we should change - the key's flag, as this is assignment. */ - if (HvSHAREKEYS(hv)) { - /* Need to swap the key we have for a key with the flags we - need. As keys are shared we can't just write to the - flag, so we share the new one, unshare the old one. */ - HEK * const new_hek = share_hek_flags(key, klen, hash, - masked_flags); - unshare_hek (HeKEY_hek(entry)); - HeKEY_hek(entry) = new_hek; - } - else if (hv == PL_strtab) { - /* PL_strtab is usually the only hash without HvSHAREKEYS, - so putting this test here is cheap */ - if (flags & HVhek_FREEKEY) - Safefree(key); - Perl_croak(aTHX_ S_strtab_error, - action & HV_FETCH_LVALUE ? "fetch" : "store"); - } - else - HeKFLAGS(entry) = masked_flags; - if (masked_flags & HVhek_ENABLEHVKFLAGS) - HvHASKFLAGS_on(hv); - } - if (HeVAL(entry) == &PL_sv_placeholder) { - /* yes, can store into placeholder slot */ - if (action & HV_FETCH_LVALUE) { - if (SvMAGICAL(hv)) { - /* This preserves behaviour with the old hv_fetch - implementation which at this point would bail out - with a break; (at "if we find a placeholder, we - pretend we haven't found anything") - - That break mean that if a placeholder were found, it - caused a call into hv_store, which in turn would - check magic, and if there is no magic end up pretty - much back at this point (in hv_store's code). */ - break; - } - /* LVAL fetch which actually needs a store. */ - val = newSV(0); - HvPLACEHOLDERS(hv)--; - } else { - /* store */ - if (val != &PL_sv_placeholder) - HvPLACEHOLDERS(hv)--; - } - HeVAL(entry) = val; - } else if (action & HV_FETCH_ISSTORE) { - SvREFCNT_dec(HeVAL(entry)); - HeVAL(entry) = val; - } - } else if (HeVAL(entry) == &PL_sv_placeholder) { - /* if we find a placeholder, we pretend we haven't found - anything */ - break; - } - if (flags & HVhek_FREEKEY) - Safefree(key); - if (return_svp) { + if (HeKFLAGS(entry) != masked_flags) { + /* We match if HVhek_UTF8 bit in our flags and hash key's + match. But if entry was set previously with HVhek_WASUTF8 + and key now doesn't (or vice versa) then we should change + the key's flag, as this is assignment. */ + if (HvSHAREKEYS(hv)) { + /* Need to swap the key we have for a key with the flags we + need. As keys are shared we can't just write to the + flag, so we share the new one, unshare the old one. */ + HEK * const new_hek = share_hek_flags(key, klen, hash, + masked_flags); + unshare_hek (HeKEY_hek(entry)); + HeKEY_hek(entry) = new_hek; + } + else if (hv == PL_strtab) { + /* PL_strtab is usually the only hash without HvSHAREKEYS, + so putting this test here is cheap */ + if (flags & HVhek_FREEKEY) + Safefree(key); + Perl_croak(aTHX_ S_strtab_error, + action & HV_FETCH_LVALUE ? "fetch" : "store"); + } + else + HeKFLAGS(entry) = masked_flags; + if (masked_flags & HVhek_ENABLEHVKFLAGS) + HvHASKFLAGS_on(hv); + } + if (HeVAL(entry) == &PL_sv_placeholder) { + /* yes, can store into placeholder slot */ + if (action & HV_FETCH_LVALUE) { + if (SvMAGICAL(hv)) { + /* This preserves behaviour with the old hv_fetch + implementation which at this point would bail out + with a break; (at "if we find a placeholder, we + pretend we haven't found anything") + + That break mean that if a placeholder were found, it + caused a call into hv_store, which in turn would + check magic, and if there is no magic end up pretty + much back at this point (in hv_store's code). */ + break; + } + /* LVAL fetch which actually needs a store. */ + val = newSV(0); + HvPLACEHOLDERS(hv)--; + } else { + /* store */ + if (val != &PL_sv_placeholder) + HvPLACEHOLDERS(hv)--; + } + HeVAL(entry) = val; + } else if (action & HV_FETCH_ISSTORE) { + SvREFCNT_dec(HeVAL(entry)); + HeVAL(entry) = val; + } + } else if (HeVAL(entry) == &PL_sv_placeholder) { + /* if we find a placeholder, we pretend we haven't found + anything */ + break; + } + if (flags & HVhek_FREEKEY) + Safefree(key); + if (return_svp) { return (void *) &HeVAL(entry); - } - return entry; + } + return entry; } not_found: #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ if (!(action & HV_FETCH_ISSTORE) - && SvRMAGICAL((const SV *)hv) - && mg_find((const SV *)hv, PERL_MAGIC_env)) { - unsigned long len; - const char * const env = PerlEnv_ENVgetenv_len(key,&len); - if (env) { - sv = newSVpvn(env,len); - SvTAINTED_on(sv); - return hv_common(hv, keysv, key, klen, flags, - HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, - sv, hash); - } + && SvRMAGICAL((const SV *)hv) + && mg_find((const SV *)hv, PERL_MAGIC_env)) { + unsigned long len; + const char * const env = PerlEnv_ENVgetenv_len(key,&len); + if (env) { + sv = newSVpvn(env,len); + SvTAINTED_on(sv); + return hv_common(hv, keysv, key, klen, flags, + HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, + sv, hash); + } } #endif if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) { - hv_notallowed(flags, key, klen, - "Attempt to access disallowed key '%" SVf "' in" - " a restricted hash"); + hv_notallowed(flags, key, klen, + "Attempt to access disallowed key '%" SVf "' in" + " a restricted hash"); } if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) { - /* Not doing some form of store, so return failure. */ - if (flags & HVhek_FREEKEY) - Safefree(key); - return NULL; + /* Not doing some form of store, so return failure. */ + if (flags & HVhek_FREEKEY) + Safefree(key); + return NULL; } if (action & HV_FETCH_LVALUE) { - val = action & HV_FETCH_EMPTY_HE ? NULL : newSV(0); - if (SvMAGICAL(hv)) { - /* At this point the old hv_fetch code would call to hv_store, - which in turn might do some tied magic. So we need to make that - magic check happen. */ - /* gonna assign to this, so it better be there */ - /* If a fetch-as-store fails on the fetch, then the action is to - recurse once into "hv_store". If we didn't do this, then that - recursive call would call the key conversion routine again. - However, as we replace the original key with the converted - key, this would result in a double conversion, which would show - up as a bug if the conversion routine is not idempotent. - Hence the use of HV_DISABLE_UVAR_XKEY. */ - return hv_common(hv, keysv, key, klen, flags, - HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, - val, hash); - /* XXX Surely that could leak if the fetch-was-store fails? - Just like the hv_fetch. */ - } + val = action & HV_FETCH_EMPTY_HE ? NULL : newSV(0); + if (SvMAGICAL(hv)) { + /* At this point the old hv_fetch code would call to hv_store, + which in turn might do some tied magic. So we need to make that + magic check happen. */ + /* gonna assign to this, so it better be there */ + /* If a fetch-as-store fails on the fetch, then the action is to + recurse once into "hv_store". If we didn't do this, then that + recursive call would call the key conversion routine again. + However, as we replace the original key with the converted + key, this would result in a double conversion, which would show + up as a bug if the conversion routine is not idempotent. + Hence the use of HV_DISABLE_UVAR_XKEY. */ + return hv_common(hv, keysv, key, klen, flags, + HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp, + val, hash); + /* XXX Surely that could leak if the fetch-was-store fails? + Just like the hv_fetch. */ + } } /* Welcome to hv_store... */ if (!HvARRAY(hv)) { - /* Not sure if we can get here. I think the only case of oentry being - NULL is for %ENV with dynamic env fetch. But that should disappear - with magic in the previous code. */ - char *array; - Newxz(array, - PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), - char); - HvARRAY(hv) = (HE**)array; + /* Not sure if we can get here. I think the only case of oentry being + NULL is for %ENV with dynamic env fetch. But that should disappear + with magic in the previous code. */ + char *array; + Newxz(array, + PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), + char); + HvARRAY(hv) = (HE**)array; } oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max]; @@ -822,17 +822,17 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* share_hek_flags will do the free for us. This might be considered bad API design. */ if (HvSHAREKEYS(hv)) - HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags); + HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags); else if (hv == PL_strtab) { - /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting - this test here is cheap */ - if (flags & HVhek_FREEKEY) - Safefree(key); - Perl_croak(aTHX_ S_strtab_error, - action & HV_FETCH_LVALUE ? "fetch" : "store"); + /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting + this test here is cheap */ + if (flags & HVhek_FREEKEY) + Safefree(key); + Perl_croak(aTHX_ S_strtab_error, + action & HV_FETCH_LVALUE ? "fetch" : "store"); } else /* gotta do the real thing */ - HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags); + HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags); HeVAL(entry) = val; #ifdef PERL_HASH_RANDOMIZE_KEYS @@ -879,9 +879,9 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, #endif if (val == &PL_sv_placeholder) - HvPLACEHOLDERS(hv)++; + HvPLACEHOLDERS(hv)++; if (masked_flags & HVhek_ENABLEHVKFLAGS) - HvHASKFLAGS_on(hv); + HvHASKFLAGS_on(hv); xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ if ( in_collision && DO_HSPLIT(xhv) ) { @@ -908,7 +908,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } if (return_svp) { - return entry ? (void *) &HeVAL(entry) : NULL; + return entry ? (void *) &HeVAL(entry) : NULL; } return (void *) entry; } @@ -923,14 +923,14 @@ S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store) *needs_copy = FALSE; *needs_store = TRUE; while (mg) { - if (isUPPER(mg->mg_type)) { - *needs_copy = TRUE; - if (mg->mg_type == PERL_MAGIC_tied) { - *needs_store = FALSE; - return; /* We've set all there is to set. */ - } - } - mg = mg->mg_moremagic; + if (isUPPER(mg->mg_type)) { + *needs_copy = TRUE; + if (mg->mg_type == PERL_MAGIC_tied) { + *needs_store = FALSE; + return; /* We've set all there is to set. */ + } + } + mg = mg->mg_moremagic; } } @@ -957,9 +957,9 @@ Perl_hv_scalar(pTHX_ HV *hv) PERL_ARGS_ASSERT_HV_SCALAR; if (SvRMAGICAL(hv)) { - MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied); - if (mg) - return magic_scalarpack(hv, mg); + MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied); + if (mg) + return magic_scalarpack(hv, mg); } sv = sv_newmortal(); @@ -1103,7 +1103,7 @@ value, or 0 to ask for it to be computed. STATIC SV * S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, - int k_flags, I32 d_flags, U32 hash) + int k_flags, I32 d_flags, U32 hash) { XPVHV* xhv; HE *entry; @@ -1118,65 +1118,65 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, HV *stash = NULL; if (SvRMAGICAL(hv)) { - bool needs_copy; - bool needs_store; - hv_magic_check (hv, &needs_copy, &needs_store); - - if (needs_copy) { - SV *sv; - entry = (HE *) hv_common(hv, keysv, key, klen, - k_flags & ~HVhek_FREEKEY, - HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY, - NULL, hash); - sv = entry ? HeVAL(entry) : NULL; - if (sv) { - if (SvMAGICAL(sv)) { - mg_clear(sv); - } - if (!needs_store) { - if (mg_find(sv, PERL_MAGIC_tiedelem)) { - /* No longer an element */ - sv_unmagic(sv, PERL_MAGIC_tiedelem); - return sv; - } - return NULL; /* element cannot be deleted */ - } + bool needs_copy; + bool needs_store; + hv_magic_check (hv, &needs_copy, &needs_store); + + if (needs_copy) { + SV *sv; + entry = (HE *) hv_common(hv, keysv, key, klen, + k_flags & ~HVhek_FREEKEY, + HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY, + NULL, hash); + sv = entry ? HeVAL(entry) : NULL; + if (sv) { + if (SvMAGICAL(sv)) { + mg_clear(sv); + } + if (!needs_store) { + if (mg_find(sv, PERL_MAGIC_tiedelem)) { + /* No longer an element */ + sv_unmagic(sv, PERL_MAGIC_tiedelem); + return sv; + } + return NULL; /* element cannot be deleted */ + } #ifdef ENV_IS_CASELESS - else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { - /* XXX This code isn't UTF8 clean. */ - keysv = newSVpvn_flags(key, klen, SVs_TEMP); - if (k_flags & HVhek_FREEKEY) { - Safefree(key); - } - key = strupr(SvPVX(keysv)); - is_utf8 = 0; - k_flags = 0; - hash = 0; - } + else if (mg_find((const SV *)hv, PERL_MAGIC_env)) { + /* XXX This code isn't UTF8 clean. */ + keysv = newSVpvn_flags(key, klen, SVs_TEMP); + if (k_flags & HVhek_FREEKEY) { + Safefree(key); + } + key = strupr(SvPVX(keysv)); + is_utf8 = 0; + k_flags = 0; + hash = 0; + } #endif - } - } + } + } } xhv = (XPVHV*)SvANY(hv); if (!HvARRAY(hv)) - return NULL; + return NULL; if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) { - const char * const keysave = key; - key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); + const char * const keysave = key; + key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); if (is_utf8) k_flags |= HVhek_UTF8; - else + else k_flags &= ~HVhek_UTF8; if (key != keysave) { - if (k_flags & HVhek_FREEKEY) { - /* This shouldn't happen if our caller does what we expect, - but strictly the API allows it. */ - Safefree(keysave); - } - k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; - } + if (k_flags & HVhek_FREEKEY) { + /* This shouldn't happen if our caller does what we expect, + but strictly the API allows it. */ + Safefree(keysave); + } + k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; + } HvHASKFLAGS_on(MUTABLE_SV(hv)); } @@ -1224,66 +1224,66 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } for (; entry; oentry = &HeNEXT(entry), entry = *oentry) { - if (HeHASH(entry) != hash) /* strings can't be equal */ - continue; - if (HeKLEN(entry) != (I32)klen) - continue; - if (memNE(HeKEY(entry),key,klen)) /* is this it? */ - continue; - if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) - continue; + if (HeHASH(entry) != hash) /* strings can't be equal */ + continue; + if (HeKLEN(entry) != (I32)klen) + continue; + if (memNE(HeKEY(entry),key,klen)) /* is this it? */ + continue; + if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) + continue; found: - if (hv == PL_strtab) { - if (k_flags & HVhek_FREEKEY) - Safefree(key); - Perl_croak(aTHX_ S_strtab_error, "delete"); - } - - /* if placeholder is here, it's already been deleted.... */ - if (HeVAL(entry) == &PL_sv_placeholder) { - if (k_flags & HVhek_FREEKEY) - Safefree(key); - return NULL; - } - if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - hv_notallowed(k_flags, key, klen, - "Attempt to delete readonly key '%" SVf "' from" - " a restricted hash"); - } + if (hv == PL_strtab) { + if (k_flags & HVhek_FREEKEY) + Safefree(key); + Perl_croak(aTHX_ S_strtab_error, "delete"); + } + + /* if placeholder is here, it's already been deleted.... */ + if (HeVAL(entry) == &PL_sv_placeholder) { + if (k_flags & HVhek_FREEKEY) + Safefree(key); + return NULL; + } + if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { + hv_notallowed(k_flags, key, klen, + "Attempt to delete readonly key '%" SVf "' from" + " a restricted hash"); + } if (k_flags & HVhek_FREEKEY) Safefree(key); - /* If this is a stash and the key ends with ::, then someone is - * deleting a package. - */ - if (HeVAL(entry) && HvENAME_get(hv)) { - gv = (GV *)HeVAL(entry); - if (keysv) key = SvPV(keysv, klen); - if (( - (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':') - || - (klen == 1 && key[0] == ':') - ) - && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6)) - && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv)) - && HvENAME_get(stash)) { - /* A previous version of this code checked that the - * GV was still in the symbol table by fetching the - * GV with its name. That is not necessary (and - * sometimes incorrect), as HvENAME cannot be set - * on hv if it is not in the symtab. */ - mro_changes = 2; - /* Hang on to it for a bit. */ - SvREFCNT_inc_simple_void_NN( - sv_2mortal((SV *)gv) - ); - } - else if (memEQs(key, klen, "ISA") && GvAV(gv)) { + /* If this is a stash and the key ends with ::, then someone is + * deleting a package. + */ + if (HeVAL(entry) && HvENAME_get(hv)) { + gv = (GV *)HeVAL(entry); + if (keysv) key = SvPV(keysv, klen); + if (( + (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':') + || + (klen == 1 && key[0] == ':') + ) + && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6)) + && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv)) + && HvENAME_get(stash)) { + /* A previous version of this code checked that the + * GV was still in the symbol table by fetching the + * GV with its name. That is not necessary (and + * sometimes incorrect), as HvENAME cannot be set + * on hv if it is not in the symtab. */ + mro_changes = 2; + /* Hang on to it for a bit. */ + SvREFCNT_inc_simple_void_NN( + sv_2mortal((SV *)gv) + ); + } + else if (memEQs(key, klen, "ISA") && GvAV(gv)) { AV *isa = GvAV(gv); MAGIC *mg = mg_find((SV*)isa, PERL_MAGIC_isa); - mro_changes = 1; + mro_changes = 1; if (mg) { if (mg->mg_obj == (SV*)gv) { /* This is the only stash this ISA was used for. @@ -1346,63 +1346,63 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } } } - } - - sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry)); - HeVAL(entry) = &PL_sv_placeholder; - if (sv) { - /* deletion of method from stash */ - if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv) - && HvENAME_get(hv)) - mro_method_changed_in(hv); - } - - /* - * If a restricted hash, rather than really deleting the entry, put - * a placeholder there. This marks the key as being "approved", so - * we can still access via not-really-existing key without raising - * an error. - */ - if (SvREADONLY(hv)) - /* We'll be saving this slot, so the number of allocated keys - * doesn't go down, but the number placeholders goes up */ - HvPLACEHOLDERS(hv)++; - else { - *oentry = HeNEXT(entry); - if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */) - HvLAZYDEL_on(hv); - else { - if (SvOOK(hv) && HvLAZYDEL(hv) && - entry == HeNEXT(HvAUX(hv)->xhv_eiter)) - HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry); - hv_free_ent(hv, entry); - } - xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ - if (xhv->xhv_keys == 0) - HvHASKFLAGS_off(hv); - } - - if (d_flags & G_DISCARD) { - SvREFCNT_dec(sv); - sv = NULL; - } - - if (mro_changes == 1) mro_isa_changed_in(hv); - else if (mro_changes == 2) - mro_package_moved(NULL, stash, gv, 1); - - return sv; + } + + sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry)); + HeVAL(entry) = &PL_sv_placeholder; + if (sv) { + /* deletion of method from stash */ + if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv) + && HvENAME_get(hv)) + mro_method_changed_in(hv); + } + + /* + * If a restricted hash, rather than really deleting the entry, put + * a placeholder there. This marks the key as being "approved", so + * we can still access via not-really-existing key without raising + * an error. + */ + if (SvREADONLY(hv)) + /* We'll be saving this slot, so the number of allocated keys + * doesn't go down, but the number placeholders goes up */ + HvPLACEHOLDERS(hv)++; + else { + *oentry = HeNEXT(entry); + if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */) + HvLAZYDEL_on(hv); + else { + if (SvOOK(hv) && HvLAZYDEL(hv) && + entry == HeNEXT(HvAUX(hv)->xhv_eiter)) + HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry); + hv_free_ent(hv, entry); + } + xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */ + if (xhv->xhv_keys == 0) + HvHASKFLAGS_off(hv); + } + + if (d_flags & G_DISCARD) { + SvREFCNT_dec(sv); + sv = NULL; + } + + if (mro_changes == 1) mro_isa_changed_in(hv); + else if (mro_changes == 2) + mro_package_moved(NULL, stash, gv, 1); + + return sv; } not_found: if (SvREADONLY(hv)) { - hv_notallowed(k_flags, key, klen, - "Attempt to delete disallowed key '%" SVf "' from" - " a restricted hash"); + hv_notallowed(k_flags, key, klen, + "Attempt to delete disallowed key '%" SVf "' from" + " a restricted hash"); } if (k_flags & HVhek_FREEKEY) - Safefree(key); + Safefree(key); return NULL; } @@ -1483,15 +1483,15 @@ S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize) newsize--; aep = (HE**)a; do { - HE **oentry = aep + i; - HE *entry = aep[i]; + HE **oentry = aep + i; + HE *entry = aep[i]; - if (!entry) /* non-existent */ - continue; - do { + if (!entry) /* non-existent */ + continue; + do { U32 j = (HeHASH(entry) & newsize); - if (j != (U32)i) { - *oentry = HeNEXT(entry); + if (j != (U32)i) { + *oentry = HeNEXT(entry); #ifdef PERL_HASH_RANDOMIZE_KEYS /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false * insert to top, otherwise rotate the bucket rand 1 bit, @@ -1517,12 +1517,12 @@ S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize) HeNEXT(entry) = aep[j]; aep[j] = entry; } - } - else { - oentry = &HeNEXT(entry); - } - entry = *oentry; - } while (entry); + } + else { + oentry = &HeNEXT(entry); + } + entry = *oentry; + } while (entry); } while (i++ < oldsize); } @@ -1540,7 +1540,7 @@ Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) wantsize = (I32) newmax; /* possible truncation here */ if (wantsize != newmax) - return; + return; wantsize= wantsize + (wantsize >> 1); /* wantsize *= 1.5 */ if (wantsize < newmax) /* overflow detection */ @@ -1592,76 +1592,76 @@ Perl_newHVhv(pTHX_ HV *ohv) STRLEN hv_max; if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv))) - return hv; + return hv; hv_max = HvMAX(ohv); if (!SvMAGICAL((const SV *)ohv)) { - /* It's an ordinary hash, so copy it fast. AMS 20010804 */ - STRLEN i; - const bool shared = !!HvSHAREKEYS(ohv); - HE **ents, ** const oents = (HE **)HvARRAY(ohv); - char *a; - Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char); - ents = (HE**)a; - - /* In each bucket... */ - for (i = 0; i <= hv_max; i++) { - HE *prev = NULL; - HE *oent = oents[i]; - - if (!oent) { - ents[i] = NULL; - continue; - } - - /* Copy the linked list of entries. */ - for (; oent; oent = HeNEXT(oent)) { - const U32 hash = HeHASH(oent); - const char * const key = HeKEY(oent); - const STRLEN len = HeKLEN(oent); - const int flags = HeKFLAGS(oent); - HE * const ent = new_HE(); - SV *const val = HeVAL(oent); - - HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val); - HeKEY_hek(ent) + /* It's an ordinary hash, so copy it fast. AMS 20010804 */ + STRLEN i; + const bool shared = !!HvSHAREKEYS(ohv); + HE **ents, ** const oents = (HE **)HvARRAY(ohv); + char *a; + Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char); + ents = (HE**)a; + + /* In each bucket... */ + for (i = 0; i <= hv_max; i++) { + HE *prev = NULL; + HE *oent = oents[i]; + + if (!oent) { + ents[i] = NULL; + continue; + } + + /* Copy the linked list of entries. */ + for (; oent; oent = HeNEXT(oent)) { + const U32 hash = HeHASH(oent); + const char * const key = HeKEY(oent); + const STRLEN len = HeKLEN(oent); + const int flags = HeKFLAGS(oent); + HE * const ent = new_HE(); + SV *const val = HeVAL(oent); + + HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val); + HeKEY_hek(ent) = shared ? share_hek_flags(key, len, hash, flags) : save_hek_flags(key, len, hash, flags); - if (prev) - HeNEXT(prev) = ent; - else - ents[i] = ent; - prev = ent; - HeNEXT(ent) = NULL; - } - } - - HvMAX(hv) = hv_max; - HvTOTALKEYS(hv) = HvTOTALKEYS(ohv); - HvARRAY(hv) = ents; + if (prev) + HeNEXT(prev) = ent; + else + ents[i] = ent; + prev = ent; + HeNEXT(ent) = NULL; + } + } + + HvMAX(hv) = hv_max; + HvTOTALKEYS(hv) = HvTOTALKEYS(ohv); + HvARRAY(hv) = ents; } /* not magical */ else { - /* Iterate over ohv, copying keys and values one at a time. */ - HE *entry; - const I32 riter = HvRITER_get(ohv); - HE * const eiter = HvEITER_get(ohv); + /* Iterate over ohv, copying keys and values one at a time. */ + HE *entry; + const I32 riter = HvRITER_get(ohv); + HE * const eiter = HvEITER_get(ohv); STRLEN hv_keys = HvTOTALKEYS(ohv); HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys); - hv_iterinit(ohv); - while ((entry = hv_iternext_flags(ohv, 0))) { - SV *val = hv_iterval(ohv,entry); - SV * const keysv = HeSVKEY(entry); - val = SvIMMORTAL(val) ? val : newSVsv(val); - if (keysv) - (void)hv_store_ent(hv, keysv, val, 0); - else - (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val, - HeHASH(entry), HeKFLAGS(entry)); - } - HvRITER_set(ohv, riter); - HvEITER_set(ohv, eiter); + hv_iterinit(ohv); + while ((entry = hv_iternext_flags(ohv, 0))) { + SV *val = hv_iterval(ohv,entry); + SV * const keysv = HeSVKEY(entry); + val = SvIMMORTAL(val) ? val : newSVsv(val); + if (keysv) + (void)hv_store_ent(hv, keysv, val, 0); + else + (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val, + HeHASH(entry), HeKFLAGS(entry)); + } + HvRITER_set(ohv, riter); + HvEITER_set(ohv, eiter); } return hv; @@ -1685,37 +1685,37 @@ Perl_hv_copy_hints_hv(pTHX_ HV *const ohv) HV * const hv = newHV(); if (ohv) { - STRLEN hv_max = HvMAX(ohv); + STRLEN hv_max = HvMAX(ohv); STRLEN hv_keys = HvTOTALKEYS(ohv); - HE *entry; - const I32 riter = HvRITER_get(ohv); - HE * const eiter = HvEITER_get(ohv); + HE *entry; + const I32 riter = HvRITER_get(ohv); + HE * const eiter = HvEITER_get(ohv); - ENTER; - SAVEFREESV(hv); + ENTER; + SAVEFREESV(hv); HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys); - hv_iterinit(ohv); - while ((entry = hv_iternext_flags(ohv, 0))) { - SV *const sv = newSVsv(hv_iterval(ohv,entry)); - SV *heksv = HeSVKEY(entry); - if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry)); - if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem, - (char *)heksv, HEf_SVKEY); - if (heksv == HeSVKEY(entry)) - (void)hv_store_ent(hv, heksv, sv, 0); - else { - (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry), - HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry)); - SvREFCNT_dec_NN(heksv); - } - } - HvRITER_set(ohv, riter); - HvEITER_set(ohv, eiter); - - SvREFCNT_inc_simple_void_NN(hv); - LEAVE; + hv_iterinit(ohv); + while ((entry = hv_iternext_flags(ohv, 0))) { + SV *const sv = newSVsv(hv_iterval(ohv,entry)); + SV *heksv = HeSVKEY(entry); + if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry)); + if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem, + (char *)heksv, HEf_SVKEY); + if (heksv == HeSVKEY(entry)) + (void)hv_store_ent(hv, heksv, sv, 0); + else { + (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry), + HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry)); + SvREFCNT_dec_NN(heksv); + } + } + HvRITER_set(ohv, riter); + HvEITER_set(ohv, eiter); + + SvREFCNT_inc_simple_void_NN(hv); + LEAVE; } hv_magic(hv, NULL, PERL_MAGIC_hints); return hv; @@ -1732,13 +1732,13 @@ S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry) val = HeVAL(entry); if (HeKLEN(entry) == HEf_SVKEY) { - SvREFCNT_dec(HeKEY_sv(entry)); - Safefree(HeKEY_hek(entry)); + SvREFCNT_dec(HeKEY_sv(entry)); + Safefree(HeKEY_hek(entry)); } else if (HvSHAREKEYS(hv)) - unshare_hek(HeKEY_hek(entry)); + unshare_hek(HeKEY_hek(entry)); else - Safefree(HeKEY_hek(entry)); + Safefree(HeKEY_hek(entry)); del_HE(entry); return val; } @@ -1752,7 +1752,7 @@ Perl_hv_free_ent(pTHX_ HV *hv, HE *entry) PERL_ARGS_ASSERT_HV_FREE_ENT; if (!entry) - return; + return; val = hv_free_ent_ret(hv, entry); SvREFCNT_dec(val); } @@ -1764,11 +1764,11 @@ Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry) PERL_ARGS_ASSERT_HV_DELAYFREE_ENT; if (!entry) - return; + return; /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */ sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */ if (HeKLEN(entry) == HEf_SVKEY) { - sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry))); + sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry))); } hv_free_ent(hv, entry); } @@ -1792,7 +1792,7 @@ Perl_hv_clear(pTHX_ HV *hv) XPVHV* xhv; if (!hv) - return; + return; DEBUG_A(Perl_hv_assert(aTHX_ hv)); @@ -1803,41 +1803,41 @@ Perl_hv_clear(pTHX_ HV *hv) PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv); orig_ix = PL_tmps_ix; if (SvREADONLY(hv) && HvARRAY(hv) != NULL) { - /* restricted hash: convert all keys to placeholders */ - STRLEN i; - for (i = 0; i <= xhv->xhv_max; i++) { - HE *entry = (HvARRAY(hv))[i]; - for (; entry; entry = HeNEXT(entry)) { - /* not already placeholder */ - if (HeVAL(entry) != &PL_sv_placeholder) { - if (HeVAL(entry)) { - if (SvREADONLY(HeVAL(entry))) { - SV* const keysv = hv_iterkeysv(entry); - Perl_croak_nocontext( - "Attempt to delete readonly key '%" SVf "' from a restricted hash", - (void*)keysv); - } - SvREFCNT_dec_NN(HeVAL(entry)); - } - HeVAL(entry) = &PL_sv_placeholder; - HvPLACEHOLDERS(hv)++; - } - } - } + /* restricted hash: convert all keys to placeholders */ + STRLEN i; + for (i = 0; i <= xhv->xhv_max; i++) { + HE *entry = (HvARRAY(hv))[i]; + for (; entry; entry = HeNEXT(entry)) { + /* not already placeholder */ + if (HeVAL(entry) != &PL_sv_placeholder) { + if (HeVAL(entry)) { + if (SvREADONLY(HeVAL(entry))) { + SV* const keysv = hv_iterkeysv(entry); + Perl_croak_nocontext( + "Attempt to delete readonly key '%" SVf "' from a restricted hash", + (void*)keysv); + } + SvREFCNT_dec_NN(HeVAL(entry)); + } + HeVAL(entry) = &PL_sv_placeholder; + HvPLACEHOLDERS(hv)++; + } + } + } } else { - hv_free_entries(hv); - HvPLACEHOLDERS_set(hv, 0); + hv_free_entries(hv); + HvPLACEHOLDERS_set(hv, 0); - if (SvRMAGICAL(hv)) - mg_clear(MUTABLE_SV(hv)); + if (SvRMAGICAL(hv)) + mg_clear(MUTABLE_SV(hv)); - HvHASKFLAGS_off(hv); + HvHASKFLAGS_off(hv); } if (SvOOK(hv)) { if(HvENAME_get(hv)) mro_isa_changed_in(hv); - HvEITER_set(hv, NULL); + HvEITER_set(hv, NULL); } /* disarm hv's premature free guard */ if (LIKELY(PL_tmps_ix == orig_ix)) @@ -1870,7 +1870,7 @@ Perl_hv_clear_placeholders(pTHX_ HV *hv) PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS; if (items) - clear_placeholders(hv, items); + clear_placeholders(hv, items); } static void @@ -1881,40 +1881,40 @@ S_clear_placeholders(pTHX_ HV *hv, U32 items) PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS; if (items == 0) - return; + return; i = HvMAX(hv); do { - /* Loop down the linked list heads */ - HE **oentry = &(HvARRAY(hv))[i]; - HE *entry; - - while ((entry = *oentry)) { - if (HeVAL(entry) == &PL_sv_placeholder) { - *oentry = HeNEXT(entry); - if (entry == HvEITER_get(hv)) - HvLAZYDEL_on(hv); - else { - if (SvOOK(hv) && HvLAZYDEL(hv) && - entry == HeNEXT(HvAUX(hv)->xhv_eiter)) - HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry); - hv_free_ent(hv, entry); - } - - if (--items == 0) { - /* Finished. */ - I32 placeholders = HvPLACEHOLDERS_get(hv); - HvTOTALKEYS(hv) -= (IV)placeholders; - /* HvUSEDKEYS expanded */ - if ((HvTOTALKEYS(hv) - placeholders) == 0) - HvHASKFLAGS_off(hv); - HvPLACEHOLDERS_set(hv, 0); - return; - } - } else { - oentry = &HeNEXT(entry); - } - } + /* Loop down the linked list heads */ + HE **oentry = &(HvARRAY(hv))[i]; + HE *entry; + + while ((entry = *oentry)) { + if (HeVAL(entry) == &PL_sv_placeholder) { + *oentry = HeNEXT(entry); + if (entry == HvEITER_get(hv)) + HvLAZYDEL_on(hv); + else { + if (SvOOK(hv) && HvLAZYDEL(hv) && + entry == HeNEXT(HvAUX(hv)->xhv_eiter)) + HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry); + hv_free_ent(hv, entry); + } + + if (--items == 0) { + /* Finished. */ + I32 placeholders = HvPLACEHOLDERS_get(hv); + HvTOTALKEYS(hv) -= (IV)placeholders; + /* HvUSEDKEYS expanded */ + if ((HvTOTALKEYS(hv) - placeholders) == 0) + HvHASKFLAGS_off(hv); + HvPLACEHOLDERS_set(hv, 0); + return; + } + } else { + oentry = &HeNEXT(entry); + } + } } while (--i >= 0); /* You can't get here, hence assertion should always fail. */ assert (items == 0); @@ -1931,7 +1931,7 @@ S_hv_free_entries(pTHX_ HV *hv) PERL_ARGS_ASSERT_HV_FREE_ENTRIES; while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) { - SvREFCNT_dec(sv); + SvREFCNT_dec(sv); } } @@ -1958,7 +1958,7 @@ Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp) PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY; if (SvOOK(hv) && ((iter = HvAUX(hv)))) { - if ((entry = iter->xhv_eiter)) { + if ((entry = iter->xhv_eiter)) { /* the iterator may get resurrected after each * destructor call, so check each time */ if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ @@ -1977,31 +1977,31 @@ Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp) } if (!((XPVHV*)SvANY(hv))->xhv_keys) - return NULL; + return NULL; array = HvARRAY(hv); assert(array); while ( ! ((entry = array[*indexp])) ) { - if ((*indexp)++ >= HvMAX(hv)) - *indexp = 0; - assert(*indexp != orig_index); + if ((*indexp)++ >= HvMAX(hv)) + *indexp = 0; + assert(*indexp != orig_index); } array[*indexp] = HeNEXT(entry); ((XPVHV*) SvANY(hv))->xhv_keys--; if ( PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv) - && HeVAL(entry) && isGV(HeVAL(entry)) - && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry))) + && HeVAL(entry) && isGV(HeVAL(entry)) + && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry))) ) { - STRLEN klen; - const char * const key = HePV(entry,klen); - if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':') - || (klen == 1 && key[0] == ':')) { - mro_package_moved( - NULL, GvHV(HeVAL(entry)), - (GV *)HeVAL(entry), 0 - ); - } + STRLEN klen; + const char * const key = HePV(entry,klen); + if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':') + || (klen == 1 && key[0] == ':')) { + mro_package_moved( + NULL, GvHV(HeVAL(entry)), + (GV *)HeVAL(entry), 0 + ); + } } return hv_free_ent_ret(hv, entry); } @@ -2029,7 +2029,7 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) SSize_t orig_ix = PL_tmps_ix; /* silence compiler warning about unitialized vars */ if (!hv) - return; + return; save = cBOOL(SvREFCNT(hv)); DEBUG_A(Perl_hv_assert(aTHX_ hv)); xhv = (XPVHV*)SvANY(hv); @@ -2048,9 +2048,9 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) if (PL_stashcache) { DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%" HEKf "'\n", HEKfARG(HvNAME_HEK(hv)))); - (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD); + (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD); } - hv_name_set(hv, NULL, 0, 0); + hv_name_set(hv, NULL, 0, 0); } if (save) { /* avoid hv being freed when calling destructors below */ @@ -2064,12 +2064,12 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) const char *name; if (HvENAME_get(hv)) { - if (PL_phase != PERL_PHASE_DESTRUCT) - mro_isa_changed_in(hv); + if (PL_phase != PERL_PHASE_DESTRUCT) + mro_isa_changed_in(hv); if (PL_stashcache) { DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%" HEKf "'\n", HEKfARG(HvENAME_HEK(hv)))); - (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD); + (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD); } } @@ -2080,41 +2080,41 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags) if (name && PL_stashcache) { DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%" HEKf "'\n", HEKfARG(HvNAME_HEK(hv)))); - (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD); + (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD); } - hv_name_set(hv, NULL, 0, flags); + hv_name_set(hv, NULL, 0, flags); } if((meta = HvAUX(hv)->xhv_mro_meta)) { - if (meta->mro_linear_all) { - SvREFCNT_dec_NN(meta->mro_linear_all); - /* mro_linear_current is just acting as a shortcut pointer, - hence the else. */ - } - else - /* Only the current MRO is stored, so this owns the data. - */ - SvREFCNT_dec(meta->mro_linear_current); - SvREFCNT_dec(meta->mro_nextmethod); - SvREFCNT_dec(meta->isa); - SvREFCNT_dec(meta->super); - Safefree(meta); - HvAUX(hv)->xhv_mro_meta = NULL; + if (meta->mro_linear_all) { + SvREFCNT_dec_NN(meta->mro_linear_all); + /* mro_linear_current is just acting as a shortcut pointer, + hence the else. */ + } + else + /* Only the current MRO is stored, so this owns the data. + */ + SvREFCNT_dec(meta->mro_linear_current); + SvREFCNT_dec(meta->mro_nextmethod); + SvREFCNT_dec(meta->isa); + SvREFCNT_dec(meta->super); + Safefree(meta); + HvAUX(hv)->xhv_mro_meta = NULL; } if (!HvAUX(hv)->xhv_name_u.xhvnameu_name && ! HvAUX(hv)->xhv_backreferences) - SvFLAGS(hv) &= ~SVf_OOK; + SvFLAGS(hv) &= ~SVf_OOK; } if (!SvOOK(hv)) { - Safefree(HvARRAY(hv)); + Safefree(HvARRAY(hv)); xhv->xhv_max = PERL_HASH_DEFAULT_HvMAX; /* HvMAX(hv) = 7 (it's a normal hash) */ - HvARRAY(hv) = 0; + HvARRAY(hv) = 0; } /* if we're freeing the HV, the SvMAGIC field has been reused for * other purposes, and so there can't be any placeholder magic */ if (SvREFCNT(hv)) - HvPLACEHOLDERS_set(hv, 0); + HvPLACEHOLDERS_set(hv, 0); if (SvRMAGICAL(hv)) - mg_clear(MUTABLE_SV(hv)); + mg_clear(MUTABLE_SV(hv)); if (save) { /* disarm hv's premature free guard */ @@ -2162,13 +2162,13 @@ Perl_hv_fill(pTHX_ HV *const hv) * I would have thought counting up was better. * - Yves */ - HE *const *const last = ents + HvMAX(hv); - count = last + 1 - ents; + HE *const *const last = ents + HvMAX(hv); + count = last + 1 - ents; - do { - if (!*ents) - --count; - } while (++ents <= last); + do { + if (!*ents) + --count; + } while (++ents <= last); } return count; } @@ -2279,20 +2279,20 @@ Perl_hv_iterinit(pTHX_ HV *hv) PERL_ARGS_ASSERT_HV_ITERINIT; if (SvOOK(hv)) { - struct xpvhv_aux * iter = HvAUX(hv); - HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */ - if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ - HvLAZYDEL_off(hv); - hv_free_ent(hv, entry); - } - iter = HvAUX(hv); /* may have been reallocated */ - iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ - iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ + struct xpvhv_aux * iter = HvAUX(hv); + HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */ + if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ + HvLAZYDEL_off(hv); + hv_free_ent(hv, entry); + } + iter = HvAUX(hv); /* may have been reallocated */ + iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ + iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ #ifdef PERL_HASH_RANDOMIZE_KEYS iter->xhv_last_rand = iter->xhv_rand; #endif } else { - hv_auxinit(hv); + hv_auxinit(hv); } /* note this includes placeholders! */ @@ -2326,12 +2326,12 @@ Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) { PERL_ARGS_ASSERT_HV_RITER_SET; if (SvOOK(hv)) { - iter = HvAUX(hv); + iter = HvAUX(hv); } else { - if (riter == -1) - return; + if (riter == -1) + return; - iter = hv_auxinit(hv); + iter = hv_auxinit(hv); } iter->xhv_riter = riter; } @@ -2361,14 +2361,14 @@ Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) { PERL_ARGS_ASSERT_HV_EITER_SET; if (SvOOK(hv)) { - iter = HvAUX(hv); + iter = HvAUX(hv); } else { - /* 0 is the default so don't go malloc()ing a new structure just to - hold 0. */ - if (!eiter) - return; + /* 0 is the default so don't go malloc()ing a new structure just to + hold 0. */ + if (!eiter) + return; - iter = hv_auxinit(hv); + iter = hv_auxinit(hv); } iter->xhv_eiter = eiter; } @@ -2383,64 +2383,64 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags) PERL_ARGS_ASSERT_HV_NAME_SET; if (len > I32_MAX) - Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); + Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); if (SvOOK(hv)) { - iter = HvAUX(hv); - if (iter->xhv_name_u.xhvnameu_name) { - if(iter->xhv_name_count) { - if(flags & HV_NAME_SETALL) { - HEK ** const this_name = HvAUX(hv)->xhv_name_u.xhvnameu_names; - HEK **hekp = this_name + ( - iter->xhv_name_count < 0 - ? -iter->xhv_name_count - : iter->xhv_name_count - ); - while(hekp-- > this_name+1) - unshare_hek_or_pvn(*hekp, 0, 0, 0); - /* The first elem may be null. */ - if(*this_name) unshare_hek_or_pvn(*this_name, 0, 0, 0); - Safefree(this_name); + iter = HvAUX(hv); + if (iter->xhv_name_u.xhvnameu_name) { + if(iter->xhv_name_count) { + if(flags & HV_NAME_SETALL) { + HEK ** const this_name = HvAUX(hv)->xhv_name_u.xhvnameu_names; + HEK **hekp = this_name + ( + iter->xhv_name_count < 0 + ? -iter->xhv_name_count + : iter->xhv_name_count + ); + while(hekp-- > this_name+1) + unshare_hek_or_pvn(*hekp, 0, 0, 0); + /* The first elem may be null. */ + if(*this_name) unshare_hek_or_pvn(*this_name, 0, 0, 0); + Safefree(this_name); iter = HvAUX(hv); /* may been realloced */ - spot = &iter->xhv_name_u.xhvnameu_name; - iter->xhv_name_count = 0; - } - else { - if(iter->xhv_name_count > 0) { - /* shift some things over */ - Renew( - iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK * - ); - spot = iter->xhv_name_u.xhvnameu_names; - spot[iter->xhv_name_count] = spot[1]; - spot[1] = spot[0]; - iter->xhv_name_count = -(iter->xhv_name_count + 1); - } - else if(*(spot = iter->xhv_name_u.xhvnameu_names)) { - unshare_hek_or_pvn(*spot, 0, 0, 0); - } - } - } - else if (flags & HV_NAME_SETALL) { - unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0); + spot = &iter->xhv_name_u.xhvnameu_name; + iter->xhv_name_count = 0; + } + else { + if(iter->xhv_name_count > 0) { + /* shift some things over */ + Renew( + iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK * + ); + spot = iter->xhv_name_u.xhvnameu_names; + spot[iter->xhv_name_count] = spot[1]; + spot[1] = spot[0]; + iter->xhv_name_count = -(iter->xhv_name_count + 1); + } + else if(*(spot = iter->xhv_name_u.xhvnameu_names)) { + unshare_hek_or_pvn(*spot, 0, 0, 0); + } + } + } + else if (flags & HV_NAME_SETALL) { + unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0); iter = HvAUX(hv); /* may been realloced */ - spot = &iter->xhv_name_u.xhvnameu_name; - } - else { - HEK * const existing_name = iter->xhv_name_u.xhvnameu_name; - Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *); - iter->xhv_name_count = -2; - spot = iter->xhv_name_u.xhvnameu_names; - spot[1] = existing_name; - } - } - else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; } + spot = &iter->xhv_name_u.xhvnameu_name; + } + else { + HEK * const existing_name = iter->xhv_name_u.xhvnameu_name; + Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *); + iter->xhv_name_count = -2; + spot = iter->xhv_name_u.xhvnameu_names; + spot[1] = existing_name; + } + } + else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; } } else { - if (name == 0) - return; + if (name == 0) + return; - iter = hv_auxinit(hv); - spot = &iter->xhv_name_u.xhvnameu_name; + iter = hv_auxinit(hv); + spot = &iter->xhv_name_u.xhvnameu_name; } PERL_HASH(hash, name, len); *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL; @@ -2457,11 +2457,11 @@ hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U3 if (flags & SVf_UTF8) return (bytes_cmp_utf8( (const U8*)HEK_KEY(hek), HEK_LEN(hek), - (const U8*)pv, pvlen) == 0); + (const U8*)pv, pvlen) == 0); else return (bytes_cmp_utf8( (const U8*)pv, pvlen, - (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0); + (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0); } else return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv) @@ -2489,45 +2489,45 @@ Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags) PERL_ARGS_ASSERT_HV_ENAME_ADD; if (len > I32_MAX) - Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); + Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); PERL_HASH(hash, name, len); if (aux->xhv_name_count) { - I32 count = aux->xhv_name_count; - HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0); - HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count); - while (hekp-- > xhv_name) - { - assert(*hekp); - if ( + I32 count = aux->xhv_name_count; + HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names + (count<0); + HEK **hekp = xhv_name + (count < 0 ? -count - 1 : count); + while (hekp-- > xhv_name) + { + assert(*hekp); + if ( (HEK_UTF8(*hekp) || (flags & SVf_UTF8)) ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags) - : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)) + : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len)) ) { - if (hekp == xhv_name && count < 0) - aux->xhv_name_count = -count; - return; - } - } - if (count < 0) aux->xhv_name_count--, count = -count; - else aux->xhv_name_count++; - Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *); - (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); + if (hekp == xhv_name && count < 0) + aux->xhv_name_count = -count; + return; + } + } + if (count < 0) aux->xhv_name_count--, count = -count; + else aux->xhv_name_count++; + Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *); + (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); } else { - HEK *existing_name = aux->xhv_name_u.xhvnameu_name; - if ( - existing_name && ( + HEK *existing_name = aux->xhv_name_u.xhvnameu_name; + if ( + existing_name && ( (HEK_UTF8(existing_name) || (flags & SVf_UTF8)) ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags) - : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len)) - ) - ) return; - Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *); - aux->xhv_name_count = existing_name ? 2 : -2; - *aux->xhv_name_u.xhvnameu_names = existing_name; - (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); + : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len)) + ) + ) return; + Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *); + aux->xhv_name_count = existing_name ? 2 : -2; + *aux->xhv_name_u.xhvnameu_names = existing_name; + (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash); } } @@ -2551,7 +2551,7 @@ Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags) PERL_ARGS_ASSERT_HV_ENAME_DELETE; if (len > I32_MAX) - Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); + Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len); if (!SvOOK(hv)) return; @@ -2559,53 +2559,53 @@ Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags) if (!aux->xhv_name_u.xhvnameu_name) return; if (aux->xhv_name_count) { - HEK ** const namep = aux->xhv_name_u.xhvnameu_names; - I32 const count = aux->xhv_name_count; - HEK **victim = namep + (count < 0 ? -count : count); - while (victim-- > namep + 1) - if ( + HEK ** const namep = aux->xhv_name_u.xhvnameu_names; + I32 const count = aux->xhv_name_count; + HEK **victim = namep + (count < 0 ? -count : count); + while (victim-- > namep + 1) + if ( (HEK_UTF8(*victim) || (flags & SVf_UTF8)) ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags) - : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len)) - ) { - unshare_hek_or_pvn(*victim, 0, 0, 0); + : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len)) + ) { + unshare_hek_or_pvn(*victim, 0, 0, 0); aux = HvAUX(hv); /* may been realloced */ - if (count < 0) ++aux->xhv_name_count; - else --aux->xhv_name_count; - if ( - (aux->xhv_name_count == 1 || aux->xhv_name_count == -1) - && !*namep - ) { /* if there are none left */ - Safefree(namep); - aux->xhv_name_u.xhvnameu_names = NULL; - aux->xhv_name_count = 0; - } - else { - /* Move the last one back to fill the empty slot. It - does not matter what order they are in. */ - *victim = *(namep + (count < 0 ? -count : count) - 1); - } - return; - } - if ( - count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8)) + if (count < 0) ++aux->xhv_name_count; + else --aux->xhv_name_count; + if ( + (aux->xhv_name_count == 1 || aux->xhv_name_count == -1) + && !*namep + ) { /* if there are none left */ + Safefree(namep); + aux->xhv_name_u.xhvnameu_names = NULL; + aux->xhv_name_count = 0; + } + else { + /* Move the last one back to fill the empty slot. It + does not matter what order they are in. */ + *victim = *(namep + (count < 0 ? -count : count) - 1); + } + return; + } + if ( + count > 0 && ((HEK_UTF8(*namep) || (flags & SVf_UTF8)) ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags) - : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len)) + : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len)) ) - ) { - aux->xhv_name_count = -count; - } + ) { + aux->xhv_name_count = -count; + } } else if( (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8)) ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags) - : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len && + : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len && memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len)) ) { - HEK * const namehek = aux->xhv_name_u.xhvnameu_name; - Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *); - *aux->xhv_name_u.xhvnameu_names = namehek; - aux->xhv_name_count = -1; + HEK * const namehek = aux->xhv_name_u.xhvnameu_name; + Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *); + *aux->xhv_name_u.xhvnameu_names = namehek; + aux->xhv_name_count = -1; } } @@ -2626,15 +2626,15 @@ Perl_hv_kill_backrefs(pTHX_ HV *hv) { PERL_ARGS_ASSERT_HV_KILL_BACKREFS; if (!SvOOK(hv)) - return; + return; av = HvAUX(hv)->xhv_backreferences; if (av) { - HvAUX(hv)->xhv_backreferences = 0; - Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av); - if (SvTYPE(av) == SVt_PVAV) - SvREFCNT_dec_NN(av); + HvAUX(hv)->xhv_backreferences = 0; + Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av); + if (SvTYPE(av) == SVt_PVAV) + SvREFCNT_dec_NN(av); } } @@ -2684,21 +2684,21 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) xhv = (XPVHV*)SvANY(hv); if (!SvOOK(hv)) { - /* Too many things (well, pp_each at least) merrily assume that you can - call hv_iternext without calling hv_iterinit, so we'll have to deal - with it. */ - hv_iterinit(hv); + /* Too many things (well, pp_each at least) merrily assume that you can + call hv_iternext without calling hv_iterinit, so we'll have to deal + with it. */ + hv_iterinit(hv); } iter = HvAUX(hv); oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ if (SvMAGICAL(hv) && SvRMAGICAL(hv)) { - if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) { + if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) { SV * const key = sv_newmortal(); if (entry) { sv_setsv(key, HeSVKEY_force(entry)); SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ - HeSVKEY_set(entry, NULL); + HeSVKEY_set(entry, NULL); } else { char *k; @@ -2706,7 +2706,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) /* one HE per MAGICAL hash */ iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ - HvLAZYDEL_on(hv); /* make sure entry gets freed */ + HvLAZYDEL_on(hv); /* make sure entry gets freed */ Zero(entry, 1, HE); Newxz(k, HEK_BASESIZE + sizeof(const SV *), char); hek = (HEK*)k; @@ -2724,21 +2724,21 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) del_HE(entry); iter = HvAUX(hv); /* may been realloced */ iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */ - HvLAZYDEL_off(hv); + HvLAZYDEL_off(hv); return NULL; } } #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */ if (!entry && SvRMAGICAL((const SV *)hv) - && mg_find((const SV *)hv, PERL_MAGIC_env)) { - prime_env_iter(); + && mg_find((const SV *)hv, PERL_MAGIC_env)) { + prime_env_iter(); #ifdef VMS - /* The prime_env_iter() on VMS just loaded up new hash values - * so the iteration count needs to be reset back to the beginning - */ - hv_iterinit(hv); - iter = HvAUX(hv); - oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ + /* The prime_env_iter() on VMS just loaded up new hash values + * so the iteration count needs to be reset back to the beginning + */ + hv_iterinit(hv); + iter = HvAUX(hv); + oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */ #endif } #endif @@ -2749,7 +2749,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) /* At start of hash, entry is NULL. */ if (entry) { - entry = HeNEXT(entry); + entry = HeNEXT(entry); if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { /* * Skip past any placeholders -- don't want to include them in @@ -2758,7 +2758,7 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) while (entry && HeVAL(entry) == &PL_sv_placeholder) { entry = HeNEXT(entry); } - } + } } #ifdef PERL_HASH_RANDOMIZE_KEYS @@ -2776,31 +2776,31 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) /* Skip the entire loop if the hash is empty. */ if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS) - ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) { - while (!entry) { - /* OK. Come to the end of the current list. Grab the next one. */ - - iter->xhv_riter++; /* HvRITER(hv)++ */ - if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { - /* There is no next one. End of the hash. */ - iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ + ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) { + while (!entry) { + /* OK. Come to the end of the current list. Grab the next one. */ + + iter->xhv_riter++; /* HvRITER(hv)++ */ + if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { + /* There is no next one. End of the hash. */ + iter->xhv_riter = -1; /* HvRITER(hv) = -1 */ #ifdef PERL_HASH_RANDOMIZE_KEYS iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */ #endif - break; - } + break; + } entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ]; - if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { - /* If we have an entry, but it's a placeholder, don't count it. - Try the next. */ - while (entry && HeVAL(entry) == &PL_sv_placeholder) - entry = HeNEXT(entry); - } - /* Will loop again if this linked list starts NULL - (for HV_ITERNEXT_WANTPLACEHOLDERS) - or if we run through it and find only placeholders. */ - } + if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { + /* If we have an entry, but it's a placeholder, don't count it. + Try the next. */ + while (entry && HeVAL(entry) == &PL_sv_placeholder) + entry = HeNEXT(entry); + } + /* Will loop again if this linked list starts NULL + (for HV_ITERNEXT_WANTPLACEHOLDERS) + or if we run through it and find only placeholders. */ + } } else { iter->xhv_riter = -1; @@ -2810,8 +2810,8 @@ Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) } if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */ - HvLAZYDEL_off(hv); - hv_free_ent(hv, oldentry); + HvLAZYDEL_off(hv); + hv_free_ent(hv, oldentry); } iter = HvAUX(hv); /* may been realloced */ @@ -2834,14 +2834,14 @@ Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen) PERL_ARGS_ASSERT_HV_ITERKEY; if (HeKLEN(entry) == HEf_SVKEY) { - STRLEN len; - char * const p = SvPV(HeKEY_sv(entry), len); - *retlen = len; - return p; + STRLEN len; + char * const p = SvPV(HeKEY_sv(entry), len); + *retlen = len; + return p; } else { - *retlen = HeKLEN(entry); - return HeKEY(entry); + *retlen = HeKLEN(entry); + return HeKEY(entry); } } @@ -2879,14 +2879,14 @@ Perl_hv_iterval(pTHX_ HV *hv, HE *entry) PERL_ARGS_ASSERT_HV_ITERVAL; if (SvRMAGICAL(hv)) { - if (mg_find((const SV *)hv, PERL_MAGIC_tied)) { - SV* const sv = sv_newmortal(); - if (HeKLEN(entry) == HEf_SVKEY) - mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY); - else - mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry)); - return sv; - } + if (mg_find((const SV *)hv, PERL_MAGIC_tied)) { + SV* const sv = sv_newmortal(); + if (HeKLEN(entry) == HEf_SVKEY) + mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY); + else + mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry)); + return sv; + } } return HeVAL(entry); } @@ -2908,7 +2908,7 @@ Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) PERL_ARGS_ASSERT_HV_ITERNEXTSV; if (!he) - return NULL; + return NULL; *key = hv_iterkey(he, retlen); return hv_iterval(hv, he); } @@ -2957,19 +2957,19 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) struct shared_he *he = NULL; if (hek) { - /* Find the shared he which is just before us in memory. */ - he = (struct shared_he *)(((char *)hek) - - STRUCT_OFFSET(struct shared_he, - shared_he_hek)); + /* Find the shared he which is just before us in memory. */ + he = (struct shared_he *)(((char *)hek) + - STRUCT_OFFSET(struct shared_he, + shared_he_hek)); - /* Assert that the caller passed us a genuine (or at least consistent) - shared hek */ - assert (he->shared_he_he.hent_hek == hek); + /* Assert that the caller passed us a genuine (or at least consistent) + shared hek */ + assert (he->shared_he_he.hent_hek == hek); - if (he->shared_he_he.he_valu.hent_refcount - 1) { - --he->shared_he_he.he_valu.hent_refcount; - return; - } + if (he->shared_he_he.he_valu.hent_refcount - 1) { + --he->shared_he_he.he_valu.hent_refcount; + return; + } hash = HEK_HASH(hek); } else if (len < 0) { @@ -2986,14 +2986,14 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) /* what follows was the moral equivalent of: if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) { - if (--*Svp == NULL) - hv_delete(PL_strtab, str, len, G_DISCARD, hash); + if (--*Svp == NULL) + hv_delete(PL_strtab, str, len, G_DISCARD, hash); } */ xhv = (XPVHV*)SvANY(PL_strtab); /* assert(xhv_array != 0) */ oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)]; if (he) { - const HE *const he_he = &(he->shared_he_he); + const HE *const he_he = &(he->shared_he_he); for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) { if (entry == he_he) break; @@ -3022,13 +3022,13 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash) } if (!entry) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free nonexistent shared string '%s'%s" - pTHX__FORMAT, - hek ? HEK_KEY(hek) : str, - ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free nonexistent shared string '%s'%s" + pTHX__FORMAT, + hek ? HEK_KEY(hek) : str, + ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE); if (k_flags & HVhek_FREEKEY) - Safefree(str); + Safefree(str); } /* get a (constant) string ptr from the global string table @@ -3083,73 +3083,73 @@ S_share_hek_flags(pTHX_ const char *str, STRLEN len, U32 hash, int flags) /* what follows is the moral equivalent of: if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE))) - hv_store(PL_strtab, str, len, NULL, hash); + hv_store(PL_strtab, str, len, NULL, hash); - Can't rehash the shared string table, so not sure if it's worth - counting the number of entries in the linked list + Can't rehash the shared string table, so not sure if it's worth + counting the number of entries in the linked list */ /* assert(xhv_array != 0) */ entry = (HvARRAY(PL_strtab))[hindex]; for (;entry; entry = HeNEXT(entry)) { - if (HeHASH(entry) != hash) /* strings can't be equal */ - continue; - if (HeKLEN(entry) != (SSize_t) len) - continue; - if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ - continue; - if (HeKFLAGS(entry) != flags_masked) - continue; - break; + if (HeHASH(entry) != hash) /* strings can't be equal */ + continue; + if (HeKLEN(entry) != (SSize_t) len) + continue; + if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ + continue; + if (HeKFLAGS(entry) != flags_masked) + continue; + break; } if (!entry) { - /* What used to be head of the list. - If this is NULL, then we're the first entry for this slot, which - means we need to increate fill. */ - struct shared_he *new_entry; - HEK *hek; - char *k; - HE **const head = &HvARRAY(PL_strtab)[hindex]; - HE *const next = *head; - - /* We don't actually store a HE from the arena and a regular HEK. - Instead we allocate one chunk of memory big enough for both, - and put the HEK straight after the HE. This way we can find the - HE directly from the HEK. - */ - - Newx(k, STRUCT_OFFSET(struct shared_he, - shared_he_hek.hek_key[0]) + len + 2, char); - new_entry = (struct shared_he *)k; - entry = &(new_entry->shared_he_he); - hek = &(new_entry->shared_he_hek); - - Copy(str, HEK_KEY(hek), len, char); - HEK_KEY(hek)[len] = 0; - HEK_LEN(hek) = len; - HEK_HASH(hek) = hash; - HEK_FLAGS(hek) = (unsigned char)flags_masked; - - /* Still "point" to the HEK, so that other code need not know what - we're up to. */ - HeKEY_hek(entry) = hek; - entry->he_valu.hent_refcount = 0; - HeNEXT(entry) = next; - *head = entry; - - xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ - if (!next) { /* initial entry? */ - } else if ( DO_HSPLIT(xhv) ) { + /* What used to be head of the list. + If this is NULL, then we're the first entry for this slot, which + means we need to increate fill. */ + struct shared_he *new_entry; + HEK *hek; + char *k; + HE **const head = &HvARRAY(PL_strtab)[hindex]; + HE *const next = *head; + + /* We don't actually store a HE from the arena and a regular HEK. + Instead we allocate one chunk of memory big enough for both, + and put the HEK straight after the HE. This way we can find the + HE directly from the HEK. + */ + + Newx(k, STRUCT_OFFSET(struct shared_he, + shared_he_hek.hek_key[0]) + len + 2, char); + new_entry = (struct shared_he *)k; + entry = &(new_entry->shared_he_he); + hek = &(new_entry->shared_he_hek); + + Copy(str, HEK_KEY(hek), len, char); + HEK_KEY(hek)[len] = 0; + HEK_LEN(hek) = len; + HEK_HASH(hek) = hash; + HEK_FLAGS(hek) = (unsigned char)flags_masked; + + /* Still "point" to the HEK, so that other code need not know what + we're up to. */ + HeKEY_hek(entry) = hek; + entry->he_valu.hent_refcount = 0; + HeNEXT(entry) = next; + *head = entry; + + xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */ + if (!next) { /* initial entry? */ + } else if ( DO_HSPLIT(xhv) ) { const STRLEN oldsize = xhv->xhv_max + 1; hsplit(PL_strtab, oldsize, oldsize * 2); - } + } } ++entry->he_valu.hent_refcount; if (flags & HVhek_FREEKEY) - Safefree(str); + Safefree(str); return HeKEY_hek(entry); } @@ -3162,11 +3162,11 @@ Perl_hv_placeholders_p(pTHX_ HV *hv) PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P; if (!mg) { - mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0); + mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0); - if (!mg) { - Perl_die(aTHX_ "panic: hv_placeholders_p"); - } + if (!mg) { + Perl_die(aTHX_ "panic: hv_placeholders_p"); + } } return &(mg->mg_len); } @@ -3191,10 +3191,10 @@ Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph) PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET; if (mg) { - mg->mg_len = ph; + mg->mg_len = ph; } else if (ph) { - if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph)) - Perl_die(aTHX_ "panic: hv_placeholders_set"); + if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph)) + Perl_die(aTHX_ "panic: hv_placeholders_set"); } /* else we don't need to add magic to record 0 placeholders. */ } @@ -3208,34 +3208,34 @@ S_refcounted_he_value(pTHX_ const struct refcounted_he *he) switch(he->refcounted_he_data[0] & HVrhek_typemask) { case HVrhek_undef: - value = newSV(0); - break; + value = newSV(0); + break; case HVrhek_delete: - value = &PL_sv_placeholder; - break; + value = &PL_sv_placeholder; + break; case HVrhek_IV: - value = newSViv(he->refcounted_he_val.refcounted_he_u_iv); - break; + value = newSViv(he->refcounted_he_val.refcounted_he_u_iv); + break; case HVrhek_UV: - value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv); - break; + value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv); + break; case HVrhek_PV: case HVrhek_PV_UTF8: - /* Create a string SV that directly points to the bytes in our - structure. */ - value = newSV_type(SVt_PV); - SvPV_set(value, (char *) he->refcounted_he_data + 1); - SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len); - /* This stops anything trying to free it */ - SvLEN_set(value, 0); - SvPOK_on(value); - SvREADONLY_on(value); - if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8) - SvUTF8_on(value); - break; + /* Create a string SV that directly points to the bytes in our + structure. */ + value = newSV_type(SVt_PV); + SvPV_set(value, (char *) he->refcounted_he_data + 1); + SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len); + /* This stops anything trying to free it */ + SvLEN_set(value, 0); + SvPOK_on(value); + SvREADONLY_on(value); + if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8) + SvUTF8_on(value); + break; default: - Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %" UVxf, - (UV)he->refcounted_he_data[0]); + Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %" UVxf, + (UV)he->refcounted_he_data[0]); } return value; } @@ -3256,8 +3256,8 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags) U32 placeholders, max; if (flags) - Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %" UVxf, + (UV)flags); /* We could chase the chain once to get an idea of the number of keys, and call ksplit. But for now we'll make a potentially inefficient @@ -3265,77 +3265,77 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags) hv = newHV(); max = HvMAX(hv); if (!HvARRAY(hv)) { - char *array; - Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char); - HvARRAY(hv) = (HE**)array; + char *array; + Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char); + HvARRAY(hv) = (HE**)array; } placeholders = 0; while (chain) { #ifdef USE_ITHREADS - U32 hash = chain->refcounted_he_hash; + U32 hash = chain->refcounted_he_hash; #else - U32 hash = HEK_HASH(chain->refcounted_he_hek); + U32 hash = HEK_HASH(chain->refcounted_he_hek); #endif - HE **oentry = &((HvARRAY(hv))[hash & max]); - HE *entry = *oentry; - SV *value; - - for (; entry; entry = HeNEXT(entry)) { - if (HeHASH(entry) == hash) { - /* We might have a duplicate key here. If so, entry is older - than the key we've already put in the hash, so if they are - the same, skip adding entry. */ + HE **oentry = &((HvARRAY(hv))[hash & max]); + HE *entry = *oentry; + SV *value; + + for (; entry; entry = HeNEXT(entry)) { + if (HeHASH(entry) == hash) { + /* We might have a duplicate key here. If so, entry is older + than the key we've already put in the hash, so if they are + the same, skip adding entry. */ #ifdef USE_ITHREADS - const STRLEN klen = HeKLEN(entry); - const char *const key = HeKEY(entry); - if (klen == chain->refcounted_he_keylen - && (!!HeKUTF8(entry) - == !!(chain->refcounted_he_data[0] & HVhek_UTF8)) - && memEQ(key, REF_HE_KEY(chain), klen)) - goto next_please; + const STRLEN klen = HeKLEN(entry); + const char *const key = HeKEY(entry); + if (klen == chain->refcounted_he_keylen + && (!!HeKUTF8(entry) + == !!(chain->refcounted_he_data[0] & HVhek_UTF8)) + && memEQ(key, REF_HE_KEY(chain), klen)) + goto next_please; #else - if (HeKEY_hek(entry) == chain->refcounted_he_hek) - goto next_please; - if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek) - && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek) - && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek), - HeKLEN(entry))) - goto next_please; + if (HeKEY_hek(entry) == chain->refcounted_he_hek) + goto next_please; + if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek) + && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek) + && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek), + HeKLEN(entry))) + goto next_please; #endif - } - } - assert (!entry); - entry = new_HE(); + } + } + assert (!entry); + entry = new_HE(); #ifdef USE_ITHREADS - HeKEY_hek(entry) - = share_hek_flags(REF_HE_KEY(chain), - chain->refcounted_he_keylen, - chain->refcounted_he_hash, - (chain->refcounted_he_data[0] - & (HVhek_UTF8|HVhek_WASUTF8))); + HeKEY_hek(entry) + = share_hek_flags(REF_HE_KEY(chain), + chain->refcounted_he_keylen, + chain->refcounted_he_hash, + (chain->refcounted_he_data[0] + & (HVhek_UTF8|HVhek_WASUTF8))); #else - HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek); + HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek); #endif - value = refcounted_he_value(chain); - if (value == &PL_sv_placeholder) - placeholders++; - HeVAL(entry) = value; + value = refcounted_he_value(chain); + if (value == &PL_sv_placeholder) + placeholders++; + HeVAL(entry) = value; - /* Link it into the chain. */ - HeNEXT(entry) = *oentry; - *oentry = entry; + /* Link it into the chain. */ + HeNEXT(entry) = *oentry; + *oentry = entry; - HvTOTALKEYS(hv)++; + HvTOTALKEYS(hv)++; next_please: - chain = chain->refcounted_he_next; + chain = chain->refcounted_he_next; } if (placeholders) { - clear_placeholders(hv, placeholders); - HvTOTALKEYS(hv) -= placeholders; + clear_placeholders(hv, placeholders); + HvTOTALKEYS(hv) -= placeholders; } /* We could check in the loop to see if we encounter any keys with key @@ -3363,38 +3363,38 @@ if there is no value associated with the key. SV * Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain, - const char *keypv, STRLEN keylen, U32 hash, U32 flags) + const char *keypv, STRLEN keylen, U32 hash, U32 flags) { U8 utf8_flag; PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN; if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS)) - Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %" UVxf, + (UV)flags); if (!chain) - goto ret; + goto ret; if (flags & REFCOUNTED_HE_KEY_UTF8) { - /* For searching purposes, canonicalise to Latin-1 where possible. */ - const char *keyend = keypv + keylen, *p; - STRLEN nonascii_count = 0; - for (p = keypv; p != keyend; p++) { - if (! UTF8_IS_INVARIANT(*p)) { - if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) { - goto canonicalised_key; + /* For searching purposes, canonicalise to Latin-1 where possible. */ + const char *keyend = keypv + keylen, *p; + STRLEN nonascii_count = 0; + for (p = keypv; p != keyend; p++) { + if (! UTF8_IS_INVARIANT(*p)) { + if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) { + goto canonicalised_key; } - nonascii_count++; + nonascii_count++; p++; - } - } - if (nonascii_count) { - char *q; - const char *p = keypv, *keyend = keypv + keylen; - keylen -= nonascii_count; - Newx(q, keylen, char); - SAVEFREEPV(q); - keypv = q; - for (; p != keyend; p++, q++) { - U8 c = (U8)*p; + } + } + if (nonascii_count) { + char *q; + const char *p = keypv, *keyend = keypv + keylen; + keylen -= nonascii_count; + Newx(q, keylen, char); + SAVEFREEPV(q); + keypv = q; + for (; p != keyend; p++, q++) { + U8 c = (U8)*p; if (UTF8_IS_INVARIANT(c)) { *q = (char) c; } @@ -3402,35 +3402,35 @@ Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain, p++; *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p); } - } - } - flags &= ~REFCOUNTED_HE_KEY_UTF8; - canonicalised_key: ; + } + } + flags &= ~REFCOUNTED_HE_KEY_UTF8; + canonicalised_key: ; } utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0; if (!hash) - PERL_HASH(hash, keypv, keylen); + PERL_HASH(hash, keypv, keylen); for (; chain; chain = chain->refcounted_he_next) { - if ( + if ( #ifdef USE_ITHREADS - hash == chain->refcounted_he_hash && - keylen == chain->refcounted_he_keylen && - memEQ(REF_HE_KEY(chain), keypv, keylen) && - utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8) + hash == chain->refcounted_he_hash && + keylen == chain->refcounted_he_keylen && + memEQ(REF_HE_KEY(chain), keypv, keylen) && + utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8) #else - hash == HEK_HASH(chain->refcounted_he_hek) && - keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) && - memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) && - utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8) + hash == HEK_HASH(chain->refcounted_he_hek) && + keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) && + memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) && + utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8) #endif - ) { - if (flags & REFCOUNTED_HE_EXISTS) - return (chain->refcounted_he_data[0] & HVrhek_typemask) - == HVrhek_delete - ? NULL : &PL_sv_yes; - return sv_2mortal(refcounted_he_value(chain)); - } + ) { + if (flags & REFCOUNTED_HE_EXISTS) + return (chain->refcounted_he_data[0] & HVrhek_typemask) + == HVrhek_delete + ? NULL : &PL_sv_yes; + return sv_2mortal(refcounted_he_value(chain)); + } } ret: return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder; @@ -3447,7 +3447,7 @@ instead of a string/length pair. SV * Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain, - const char *key, U32 hash, U32 flags) + const char *key, U32 hash, U32 flags) { PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV; return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags); @@ -3464,19 +3464,19 @@ string/length pair. SV * Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain, - SV *key, U32 hash, U32 flags) + SV *key, U32 hash, U32 flags) { const char *keypv; STRLEN keylen; PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV; if (flags & REFCOUNTED_HE_KEY_UTF8) - Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %" UVxf, + (UV)flags); keypv = SvPV_const(key, keylen); if (SvUTF8(key)) - flags |= REFCOUNTED_HE_KEY_UTF8; + flags |= REFCOUNTED_HE_KEY_UTF8; if (!hash && SvIsCOW_shared_hash(key)) - hash = SvSHARED_HASH(key); + hash = SvSHARED_HASH(key); return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags); } @@ -3515,7 +3515,7 @@ C<refcounted_he>. struct refcounted_he * Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent, - const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags) + const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags) { STRLEN value_len = 0; const char *value_p = NULL; @@ -3527,49 +3527,49 @@ Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent, PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN; if (!value || value == &PL_sv_placeholder) { - value_type = HVrhek_delete; + value_type = HVrhek_delete; } else if (SvPOK(value)) { - value_type = HVrhek_PV; + value_type = HVrhek_PV; } else if (SvIOK(value)) { - value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV; + value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV; } else if (!SvOK(value)) { - value_type = HVrhek_undef; + value_type = HVrhek_undef; } else { - value_type = HVrhek_PV; + value_type = HVrhek_PV; } is_pv = value_type == HVrhek_PV; if (is_pv) { - /* Do it this way so that the SvUTF8() test is after the SvPV, in case - the value is overloaded, and doesn't yet have the UTF-8flag set. */ - value_p = SvPV_const(value, value_len); - if (SvUTF8(value)) - value_type = HVrhek_PV_UTF8; - key_offset = value_len + 2; + /* Do it this way so that the SvUTF8() test is after the SvPV, in case + the value is overloaded, and doesn't yet have the UTF-8flag set. */ + value_p = SvPV_const(value, value_len); + if (SvUTF8(value)) + value_type = HVrhek_PV_UTF8; + key_offset = value_len + 2; } hekflags = value_type; if (flags & REFCOUNTED_HE_KEY_UTF8) { - /* Canonicalise to Latin-1 where possible. */ - const char *keyend = keypv + keylen, *p; - STRLEN nonascii_count = 0; - for (p = keypv; p != keyend; p++) { - if (! UTF8_IS_INVARIANT(*p)) { - if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) { - goto canonicalised_key; + /* Canonicalise to Latin-1 where possible. */ + const char *keyend = keypv + keylen, *p; + STRLEN nonascii_count = 0; + for (p = keypv; p != keyend; p++) { + if (! UTF8_IS_INVARIANT(*p)) { + if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) { + goto canonicalised_key; } - nonascii_count++; + nonascii_count++; p++; - } - } - if (nonascii_count) { - char *q; - const char *p = keypv, *keyend = keypv + keylen; - keylen -= nonascii_count; - Newx(q, keylen, char); - SAVEFREEPV(q); - keypv = q; - for (; p != keyend; p++, q++) { - U8 c = (U8)*p; + } + } + if (nonascii_count) { + char *q; + const char *p = keypv, *keyend = keypv + keylen; + keylen -= nonascii_count; + Newx(q, keylen, char); + SAVEFREEPV(q); + keypv = q; + for (; p != keyend; p++, q++) { + U8 c = (U8)*p; if (UTF8_IS_INVARIANT(c)) { *q = (char) c; } @@ -3577,36 +3577,36 @@ Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent, p++; *q = (char) EIGHT_BIT_UTF8_TO_NATIVE(c, *p); } - } - } - flags &= ~REFCOUNTED_HE_KEY_UTF8; - canonicalised_key: ; + } + } + flags &= ~REFCOUNTED_HE_KEY_UTF8; + canonicalised_key: ; } if (flags & REFCOUNTED_HE_KEY_UTF8) - hekflags |= HVhek_UTF8; + hekflags |= HVhek_UTF8; if (!hash) - PERL_HASH(hash, keypv, keylen); + PERL_HASH(hash, keypv, keylen); #ifdef USE_ITHREADS he = (struct refcounted_he*) - PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 - + keylen - + key_offset); + PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 + + keylen + + key_offset); #else he = (struct refcounted_he*) - PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 - + key_offset); + PerlMemShared_malloc(sizeof(struct refcounted_he) - 1 + + key_offset); #endif he->refcounted_he_next = parent; if (is_pv) { - Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char); - he->refcounted_he_val.refcounted_he_u_len = value_len; + Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char); + he->refcounted_he_val.refcounted_he_u_len = value_len; } else if (value_type == HVrhek_IV) { - he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value); + he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value); } else if (value_type == HVrhek_UV) { - he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); + he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value); } #ifdef USE_ITHREADS @@ -3634,7 +3634,7 @@ of a string/length pair. struct refcounted_he * Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent, - const char *key, U32 hash, SV *value, U32 flags) + const char *key, U32 hash, SV *value, U32 flags) { PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV; return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags); @@ -3651,19 +3651,19 @@ string/length pair. struct refcounted_he * Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent, - SV *key, U32 hash, SV *value, U32 flags) + SV *key, U32 hash, SV *value, U32 flags) { const char *keypv; STRLEN keylen; PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV; if (flags & REFCOUNTED_HE_KEY_UTF8) - Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %" UVxf, + (UV)flags); keypv = SvPV_const(key, keylen); if (SvUTF8(key)) - flags |= REFCOUNTED_HE_KEY_UTF8; + flags |= REFCOUNTED_HE_KEY_UTF8; if (!hash && SvIsCOW_shared_hash(key)) - hash = SvSHARED_HASH(key); + hash = SvSHARED_HASH(key); return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags); } @@ -3684,23 +3684,23 @@ Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) { PERL_UNUSED_CONTEXT; while (he) { - struct refcounted_he *copy; - U32 new_count; - - HINTS_REFCNT_LOCK; - new_count = --he->refcounted_he_refcnt; - HINTS_REFCNT_UNLOCK; - - if (new_count) { - return; - } + struct refcounted_he *copy; + U32 new_count; + + HINTS_REFCNT_LOCK; + new_count = --he->refcounted_he_refcnt; + HINTS_REFCNT_UNLOCK; + + if (new_count) { + return; + } #ifndef USE_ITHREADS - unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0); + unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0); #endif - copy = he; - he = he->refcounted_he_next; - PerlMemShared_free(copy); + copy = he; + he = he->refcounted_he_next; + PerlMemShared_free(copy); } } @@ -3719,9 +3719,9 @@ Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he) { PERL_UNUSED_CONTEXT; if (he) { - HINTS_REFCNT_LOCK; - he->refcounted_he_refcnt++; - HINTS_REFCNT_UNLOCK; + HINTS_REFCNT_LOCK; + he->refcounted_he_refcnt++; + HINTS_REFCNT_UNLOCK; } return he; } @@ -3752,29 +3752,29 @@ Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) { PERL_UNUSED_CONTEXT; if (!chain) - return NULL; + return NULL; #ifdef USE_ITHREADS if (chain->refcounted_he_keylen != 1) - return NULL; + return NULL; if (*REF_HE_KEY(chain) != ':') - return NULL; + return NULL; #else if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1) - return NULL; + return NULL; if (*HEK_KEY(chain->refcounted_he_hek) != ':') - return NULL; + return NULL; #endif /* Stop anyone trying to really mess us up by adding their own value for ':' into %^H */ if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV - && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8) - return NULL; + && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8) + return NULL; if (len) - *len = chain->refcounted_he_val.refcounted_he_u_len; + *len = chain->refcounted_he_val.refcounted_he_u_len; if (flags) { - *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask) - == HVrhek_PV_UTF8) ? SVf_UTF8 : 0; + *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask) + == HVrhek_PV_UTF8) ? SVf_UTF8 : 0; } return chain->refcounted_he_data + 1; } @@ -3791,19 +3791,19 @@ for a UTF-8 label. Any other flag is ignored. void Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len, - U32 flags) + U32 flags) { SV *labelsv; PERL_ARGS_ASSERT_COP_STORE_LABEL; if (flags & ~(SVf_UTF8)) - Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf, + (UV)flags); labelsv = newSVpvn_flags(label, len, SVs_TEMP); if (flags & SVf_UTF8) - SvUTF8_on(labelsv); + SvUTF8_on(labelsv); cop->cop_hints_hash - = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0); + = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0); } /* @@ -3833,47 +3833,47 @@ Perl_hv_assert(pTHX_ HV *hv) (void)hv_iterinit(hv); while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) { - /* sanity check the values */ - if (HeVAL(entry) == &PL_sv_placeholder) - placeholders++; - else - real++; - /* sanity check the keys */ - if (HeSVKEY(entry)) { - NOOP; /* Don't know what to check on SV keys. */ - } else if (HeKUTF8(entry)) { - withflags++; - if (HeKWASUTF8(entry)) { - PerlIO_printf(Perl_debug_log, - "hash key has both WASUTF8 and UTF8: '%.*s'\n", - (int) HeKLEN(entry), HeKEY(entry)); - bad = 1; - } - } else if (HeKWASUTF8(entry)) - withflags++; + /* sanity check the values */ + if (HeVAL(entry) == &PL_sv_placeholder) + placeholders++; + else + real++; + /* sanity check the keys */ + if (HeSVKEY(entry)) { + NOOP; /* Don't know what to check on SV keys. */ + } else if (HeKUTF8(entry)) { + withflags++; + if (HeKWASUTF8(entry)) { + PerlIO_printf(Perl_debug_log, + "hash key has both WASUTF8 and UTF8: '%.*s'\n", + (int) HeKLEN(entry), HeKEY(entry)); + bad = 1; + } + } else if (HeKWASUTF8(entry)) + withflags++; } if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) { - static const char bad_count[] = "Count %d %s(s), but hash reports %d\n"; - const int nhashkeys = HvUSEDKEYS(hv); - const int nhashplaceholders = HvPLACEHOLDERS_get(hv); - - if (nhashkeys != real) { - PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys ); - bad = 1; - } - if (nhashplaceholders != placeholders) { - PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders ); - bad = 1; - } + static const char bad_count[] = "Count %d %s(s), but hash reports %d\n"; + const int nhashkeys = HvUSEDKEYS(hv); + const int nhashplaceholders = HvPLACEHOLDERS_get(hv); + + if (nhashkeys != real) { + PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys ); + bad = 1; + } + if (nhashplaceholders != placeholders) { + PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders ); + bad = 1; + } } if (withflags && ! HvHASKFLAGS(hv)) { - PerlIO_printf(Perl_debug_log, - "Hash has HASKFLAGS off but I count %d key(s) with flags\n", - withflags); - bad = 1; + PerlIO_printf(Perl_debug_log, + "Hash has HASKFLAGS off but I count %d key(s) with flags\n", + withflags); + bad = 1; } if (bad) { - sv_dump(MUTABLE_SV(hv)); + sv_dump(MUTABLE_SV(hv)); } HvRITER_set(hv, riter); /* Restore hash iterator state */ HvEITER_set(hv, eiter); @@ -36,8 +36,8 @@ struct he { HE *hent_next; /* next entry in chain */ HEK *hent_hek; /* hash key */ union { - SV *hent_val; /* scalar value that was hashed */ - Size_t hent_refcount; /* references for this shared hash key */ + SV *hent_val; /* scalar value that was hashed */ + Size_t hent_refcount; /* references for this shared hash key */ } he_valu; }; @@ -304,16 +304,16 @@ See L</hv_fill>. ) /* This macro may go away without notice. */ #define HvNAME_HEK(hv) \ - (SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name ? HvNAME_HEK_NN(hv) : NULL) + (SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name ? HvNAME_HEK_NN(hv) : NULL) #define HvNAME_get(hv) \ - ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ - ? HEK_KEY(HvNAME_HEK_NN(hv)) : NULL) + ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ + ? HEK_KEY(HvNAME_HEK_NN(hv)) : NULL) #define HvNAMELEN_get(hv) \ - ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ - ? HEK_LEN(HvNAME_HEK_NN(hv)) : 0) + ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ + ? HEK_LEN(HvNAME_HEK_NN(hv)) : 0) #define HvNAMEUTF8(hv) \ - ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ - ? HEK_UTF8(HvNAME_HEK_NN(hv)) : 0) + ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvNAME_HEK_NN(hv)) \ + ? HEK_UTF8(HvNAME_HEK_NN(hv)) : 0) #define HvENAME_HEK_NN(hv) \ ( \ HvAUX(hv)->xhv_name_count > 0 ? HvAUX(hv)->xhv_name_u.xhvnameu_names[0] : \ @@ -322,16 +322,16 @@ See L</hv_fill>. HvAUX(hv)->xhv_name_u.xhvnameu_name \ ) #define HvENAME_HEK(hv) \ - (SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name ? HvENAME_HEK_NN(hv) : NULL) + (SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name ? HvENAME_HEK_NN(hv) : NULL) #define HvENAME_get(hv) \ ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvAUX(hv)->xhv_name_count != -1) \ - ? HEK_KEY(HvENAME_HEK_NN(hv)) : NULL) + ? HEK_KEY(HvENAME_HEK_NN(hv)) : NULL) #define HvENAMELEN_get(hv) \ ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvAUX(hv)->xhv_name_count != -1) \ - ? HEK_LEN(HvENAME_HEK_NN(hv)) : 0) + ? HEK_LEN(HvENAME_HEK_NN(hv)) : 0) #define HvENAMEUTF8(hv) \ ((SvOOK(hv) && HvAUX(hv)->xhv_name_u.xhvnameu_name && HvAUX(hv)->xhv_name_count != -1) \ - ? HEK_UTF8(HvENAME_HEK_NN(hv)) : 0) + ? HEK_UTF8(HvENAME_HEK_NN(hv)) : 0) /* the number of keys (including any placeholders) - NOT PART OF THE API */ #define XHvTOTALKEYS(xhv) ((xhv)->xhv_keys) @@ -383,24 +383,24 @@ See L</hv_fill>. #define HeVAL(he) (he)->he_valu.hent_val #define HeHASH(he) HEK_HASH(HeKEY_hek(he)) #define HePV(he,lp) ((HeKLEN(he) == HEf_SVKEY) ? \ - SvPV(HeKEY_sv(he),lp) : \ - ((lp = HeKLEN(he)), HeKEY(he))) + SvPV(HeKEY_sv(he),lp) : \ + ((lp = HeKLEN(he)), HeKEY(he))) #define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ - SvUTF8(HeKEY_sv(he)) : \ - (U32)HeKUTF8(he)) + SvUTF8(HeKEY_sv(he)) : \ + (U32)HeKUTF8(he)) #define HeSVKEY(he) ((HeKEY(he) && \ - HeKLEN(he) == HEf_SVKEY) ? \ - HeKEY_sv(he) : NULL) + HeKLEN(he) == HEf_SVKEY) ? \ + HeKEY_sv(he) : NULL) #define HeSVKEY_force(he) (HeKEY(he) ? \ - ((HeKLEN(he) == HEf_SVKEY) ? \ - HeKEY_sv(he) : \ - newSVpvn_flags(HeKEY(he), \ + ((HeKLEN(he) == HEf_SVKEY) ? \ + HeKEY_sv(he) : \ + newSVpvn_flags(HeKEY(he), \ HeKLEN(he), \ SVs_TEMP | \ ( HeKUTF8(he) ? SVf_UTF8 : 0 ))) : \ - &PL_sv_undef) + &PL_sv_undef) #define HeSVKEY_set(he,sv) ((HeKLEN(he) = HEf_SVKEY), (HeKEY_sv(he) = sv)) #ifndef PERL_CORE @@ -420,8 +420,8 @@ See L</hv_fill>. #define HVhek_PLACEHOLD 0x200 /* Internal flag to create placeholder. * (may change, but Storable is a core module) */ #define HVhek_KEYCANONICAL 0x400 /* Internal flag - key is in canonical form. - If the string is UTF-8, it cannot be - converted to bytes. */ + If the string is UTF-8, it cannot be + converted to bytes. */ #define HVhek_MASK 0xFF #define HVhek_ENABLEHVKFLAGS (HVhek_MASK & ~(HVhek_UNSHARED)) @@ -442,9 +442,9 @@ See L</hv_fill>. #else # define MALLOC_OVERHEAD 16 # define PERL_HV_ARRAY_ALLOC_BYTES(size) \ - (((size) < 64) \ - ? (size) * sizeof(HE*) \ - : (size) * sizeof(HE*) * 2 - MALLOC_OVERHEAD) + (((size) < 64) \ + ? (size) * sizeof(HE*) \ + : (size) * sizeof(HE*) * 2 - MALLOC_OVERHEAD) #endif /* Flags for hv_iternext_flags. */ @@ -459,33 +459,33 @@ See L</hv_fill>. #define share_hek_hek(hek) \ (++(((struct shared_he *)(((char *)hek) \ - - STRUCT_OFFSET(struct shared_he, \ - shared_he_hek))) \ - ->shared_he_he.he_valu.hent_refcount), \ + - STRUCT_OFFSET(struct shared_he, \ + shared_he_hek))) \ + ->shared_he_he.he_valu.hent_refcount), \ hek) #define hv_store_ent(hv, keysv, val, hash) \ ((HE *) hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISSTORE, \ - (val), (hash))) + (val), (hash))) #define hv_exists_ent(hv, keysv, hash) \ cBOOL(hv_common((hv), (keysv), NULL, 0, 0, HV_FETCH_ISEXISTS, 0, (hash))) #define hv_fetch_ent(hv, keysv, lval, hash) \ ((HE *) hv_common((hv), (keysv), NULL, 0, 0, \ - ((lval) ? HV_FETCH_LVALUE : 0), NULL, (hash))) + ((lval) ? HV_FETCH_LVALUE : 0), NULL, (hash))) #define hv_delete_ent(hv, key, flags, hash) \ (MUTABLE_SV(hv_common((hv), (key), NULL, 0, 0, (flags) | HV_DELETE, \ - NULL, (hash)))) + NULL, (hash)))) #define hv_store_flags(hv, key, klen, val, hash, flags) \ ((SV**) hv_common((hv), NULL, (key), (klen), (flags), \ - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), (val), \ - (hash))) + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), (val), \ + (hash))) #define hv_store(hv, key, klen, val, hash) \ ((SV**) hv_common_key_len((hv), (key), (klen), \ - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), \ - (val), (hash))) + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), \ + (val), (hash))) @@ -494,12 +494,12 @@ See L</hv_fill>. #define hv_fetch(hv, key, klen, lval) \ ((SV**) hv_common_key_len((hv), (key), (klen), (lval) \ - ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \ - : HV_FETCH_JUST_SV, NULL, 0)) + ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \ + : HV_FETCH_JUST_SV, NULL, 0)) #define hv_delete(hv, key, klen, flags) \ (MUTABLE_SV(hv_common_key_len((hv), (key), (klen), \ - (flags) | HV_DELETE, NULL, 0))) + (flags) | HV_DELETE, NULL, 0))) /* Provide 's' suffix subs for constant strings (and avoid needing to count * chars). See STR_WITH_LEN in handy.h - because these are macros we cant use @@ -522,17 +522,17 @@ See L</hv_fill>. #ifdef PERL_CORE # define hv_storehek(hv, hek, val) \ hv_common((hv), NULL, HEK_KEY(hek), HEK_LEN(hek), HEK_UTF8(hek), \ - HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, (val), HEK_HASH(hek)) + HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, (val), HEK_HASH(hek)) # define hv_fetchhek(hv, hek, lval) \ ((SV **) \ hv_common((hv), NULL, HEK_KEY(hek), HEK_LEN(hek), HEK_UTF8(hek), \ - (lval) \ - ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \ - : HV_FETCH_JUST_SV, \ - NULL, HEK_HASH(hek))) + (lval) \ + ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) \ + : HV_FETCH_JUST_SV, \ + NULL, HEK_HASH(hek))) # define hv_deletehek(hv, hek, flags) \ hv_common((hv), NULL, HEK_KEY(hek), HEK_LEN(hek), HEK_UTF8(hek), \ - (flags)|HV_DELETE, NULL, HEK_HASH(hek)) + (flags)|HV_DELETE, NULL, HEK_HASH(hek)) #endif /* This refcounted he structure is used for storing the hints used for lexical @@ -561,10 +561,10 @@ struct refcounted_he { HEK *refcounted_he_hek; /* hint key */ #endif union { - IV refcounted_he_u_iv; - UV refcounted_he_u_uv; - STRLEN refcounted_he_u_len; - void *refcounted_he_u_ptr; /* Might be useful in future */ + IV refcounted_he_u_iv; + UV refcounted_he_u_uv; + STRLEN refcounted_he_u_len; + void *refcounted_he_u_ptr; /* Might be useful in future */ } refcounted_he_val; U32 refcounted_he_refcnt; /* reference count */ /* First byte is flags. Then NUL-terminated value. Then for ithreads, @@ -610,9 +610,9 @@ instead of a string/length pair, and no precomputed hash. #ifdef USE_ITHREADS /* A big expression to find the key offset */ #define REF_HE_KEY(chain) \ - ((((chain->refcounted_he_data[0] & 0x60) == 0x40) \ - ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0) \ - + 1 + chain->refcounted_he_data) + ((((chain->refcounted_he_data[0] & 0x60) == 0x40) \ + ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0) \ + + 1 + chain->refcounted_he_data) #endif # ifdef USE_ITHREADS @@ -72,8 +72,8 @@ Perl_CvGV(pTHX_ CV *sv) PERL_ARGS_ASSERT_CVGV; return CvNAMED(sv) - ? Perl_cvgv_from_hek(aTHX_ sv) - : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv; + ? Perl_cvgv_from_hek(aTHX_ sv) + : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv; } PERL_STATIC_INLINE I32 * @@ -105,13 +105,13 @@ S_strip_spaces(pTHX_ const char * orig, STRLEN * const len) tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP); tmps = SvPVX(tmpsv); while ((*len)--) { - if (!isSPACE(*orig)) - *tmps++ = *orig; - orig++; + if (!isSPACE(*orig)) + *tmps++ = *orig; + orig++; } *tmps = '\0'; *len = tmps - SvPVX(tmpsv); - return SvPVX(tmpsv); + return SvPVX(tmpsv); } #endif @@ -125,12 +125,12 @@ S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len) assert(mg->mg_type == PERL_MAGIC_regex_global); assert(mg->mg_len != -1); if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv)) - return (STRLEN)mg->mg_len; + return (STRLEN)mg->mg_len; else { - const STRLEN pos = (STRLEN)mg->mg_len; - /* Without this check, we may read past the end of the buffer: */ - if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1; - return sv_or_pv_pos_u2b(sv, s, pos, NULL); + const STRLEN pos = (STRLEN)mg->mg_len; + /* Without this check, we may read past the end of the buffer: */ + if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1; + return sv_or_pv_pos_u2b(sv, s, pos, NULL); } } #endif @@ -147,27 +147,27 @@ S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq) * This is complicated by the fact that PL_cop_seqmax * may have wrapped around at some point */ if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO) - return FALSE; /* not yet introduced */ + return FALSE; /* not yet introduced */ if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) { /* in compiling scope */ - if ( - (seq > COP_SEQ_RANGE_LOW(pn)) - ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1)) - : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1)) - ) - return TRUE; + if ( + (seq > COP_SEQ_RANGE_LOW(pn)) + ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1)) + : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1)) + ) + return TRUE; } else if ( - (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn)) - ? - ( seq > COP_SEQ_RANGE_LOW(pn) - || seq <= COP_SEQ_RANGE_HIGH(pn)) + (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn)) + ? + ( seq > COP_SEQ_RANGE_LOW(pn) + || seq <= COP_SEQ_RANGE_HIGH(pn)) - : ( seq > COP_SEQ_RANGE_LOW(pn) - && seq <= COP_SEQ_RANGE_HIGH(pn)) + : ( seq > COP_SEQ_RANGE_LOW(pn) + && seq <= COP_SEQ_RANGE_HIGH(pn)) ) - return TRUE; + return TRUE; return FALSE; } #endif @@ -178,9 +178,9 @@ PERL_STATIC_INLINE I32 Perl_TOPMARK(pTHX) { DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, - "MARK top %p %" IVdf "\n", - PL_markstack_ptr, - (IV)*PL_markstack_ptr))); + "MARK top %p %" IVdf "\n", + PL_markstack_ptr, + (IV)*PL_markstack_ptr))); return *PL_markstack_ptr; } @@ -188,9 +188,9 @@ PERL_STATIC_INLINE I32 Perl_POPMARK(pTHX) { DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, - "MARK pop %p %" IVdf "\n", - (PL_markstack_ptr-1), - (IV)*(PL_markstack_ptr-1)))); + "MARK pop %p %" IVdf "\n", + (PL_markstack_ptr-1), + (IV)*(PL_markstack_ptr-1)))); assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow"); return *PL_markstack_ptr--; } @@ -272,7 +272,7 @@ PERL_STATIC_INLINE SV * Perl_SvREFCNT_inc(SV *sv) { if (LIKELY(sv != NULL)) - SvREFCNT(sv)++; + SvREFCNT(sv)++; return sv; } PERL_STATIC_INLINE SV * @@ -287,17 +287,17 @@ PERL_STATIC_INLINE void Perl_SvREFCNT_inc_void(SV *sv) { if (LIKELY(sv != NULL)) - SvREFCNT(sv)++; + SvREFCNT(sv)++; } PERL_STATIC_INLINE void Perl_SvREFCNT_dec(pTHX_ SV *sv) { if (LIKELY(sv != NULL)) { - U32 rc = SvREFCNT(sv); - if (LIKELY(rc > 1)) - SvREFCNT(sv) = rc - 1; - else - Perl_sv_free2(aTHX_ sv, rc); + U32 rc = SvREFCNT(sv); + if (LIKELY(rc > 1)) + SvREFCNT(sv) = rc - 1; + else + Perl_sv_free2(aTHX_ sv, rc); } } @@ -309,9 +309,9 @@ Perl_SvREFCNT_dec_NN(pTHX_ SV *sv) PERL_ARGS_ASSERT_SVREFCNT_DEC_NN; if (LIKELY(rc > 1)) - SvREFCNT(sv) = rc - 1; + SvREFCNT(sv) = rc - 1; else - Perl_sv_free2(aTHX_ sv, rc); + Perl_sv_free2(aTHX_ sv, rc); } PERL_STATIC_INLINE void @@ -328,7 +328,7 @@ Perl_SvAMAGIC_off(SV *sv) PERL_ARGS_ASSERT_SVAMAGIC_OFF; if (SvROK(sv) && SvOBJECT(SvRV(sv))) - HvAMAGIC_off(SvSTASH(SvRV(sv))); + HvAMAGIC_off(SvSTASH(SvRV(sv))); } PERL_STATIC_INLINE U32 @@ -349,9 +349,9 @@ S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp) { PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B; if (SvGAMAGIC(sv)) { - U8 *hopped = utf8_hop((U8 *)pv, pos); - if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped); - return (STRLEN)(hopped - (U8 *)pv); + U8 *hopped = utf8_hop((U8 *)pv, pos); + if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped); + return (STRLEN)(hopped - (U8 *)pv); } return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN); } @@ -405,7 +405,7 @@ Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen) /* An invariant is trivially returned */ if (expectlen == 1) { - return uv; + return uv; } /* Remove the leading bits that indicate the number of bytes, leaving just @@ -567,7 +567,7 @@ Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep) /* Process per-byte */ while (x < send) { - if (! UTF8_IS_INVARIANT(*x)) { + if (! UTF8_IS_INVARIANT(*x)) { if (ep) { *ep = x; } @@ -742,7 +742,7 @@ S_variant_under_utf8_count(const U8* const s, const U8* const e) /* Process per-byte */ while (x < e) { - if (! UTF8_IS_INVARIANT(*x)) { + if (! UTF8_IS_INVARIANT(*x)) { count++; } @@ -1571,15 +1571,15 @@ Perl_utf8_hop(const U8 *s, SSize_t off) * In other words: in Perl UTF-8 is not just for Unicode. */ if (off >= 0) { - while (off--) - s += UTF8SKIP(s); + while (off--) + s += UTF8SKIP(s); } else { - while (off++) { - s--; - while (UTF8_IS_CONTINUATION(*s)) - s--; - } + while (off++) { + s--; + while (UTF8_IS_CONTINUATION(*s)) + s--; + } } GCC_DIAG_IGNORE(-Wcast-qual) return (U8 *)s; @@ -2063,10 +2063,10 @@ S_get_regex_charset_name(const U32 flags, STRLEN* const lenp) case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS; case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS; case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS; - case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS; - case REGEX_ASCII_MORE_RESTRICTED_CHARSET: - *lenp = 2; - return ASCII_MORE_RESTRICT_PAT_MODS; + case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS; + case REGEX_ASCII_MORE_RESTRICTED_CHARSET: + *lenp = 2; + return ASCII_MORE_RESTRICT_PAT_MODS; } /* The NOT_REACHED; hides an assert() which has a rather complex * definition in perl.h. */ @@ -2500,9 +2500,9 @@ Perl_foldEQ(const char *s1, const char *s2, I32 len) assert(len >= 0); while (len--) { - if (*a != *b && *a != PL_fold[*b]) - return 0; - a++,b++; + if (*a != *b && *a != PL_fold[*b]) + return 0; + a++,b++; } return 1; } @@ -2523,10 +2523,10 @@ Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len) assert(len >= 0); while (len--) { - if (*a != *b && *a != PL_fold_latin1[*b]) { - return 0; - } - a++, b++; + if (*a != *b && *a != PL_fold_latin1[*b]) { + return 0; + } + a++, b++; } return 1; } @@ -2552,9 +2552,9 @@ Perl_foldEQ_locale(const char *s1, const char *s2, I32 len) assert(len >= 0); while (len--) { - if (*a != *b && *a != PL_fold_locale[*b]) - return 0; - a++,b++; + if (*a != *b && *a != PL_fold_locale[*b]) + return 0; + a++,b++; } return 1; } diff --git a/intrpvar.h b/intrpvar.h index f16d6dd3bc..a9e13d7187 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -36,7 +36,7 @@ PERLVAR(I, stack_base, SV **) PERLVAR(I, stack_max, SV **) PERLVAR(I, savestack, ANY *) /* items that need to be restored when - LEAVEing scopes we've ENTERed */ + LEAVEing scopes we've ENTERed */ PERLVAR(I, savestack_ix, I32) PERLVAR(I, savestack_max, I32) @@ -50,7 +50,7 @@ PERLVARI(I, tmps_floor, SSize_t, -1) PERLVAR(I, tmps_max, SSize_t) /* first unalloced slot in tmps stack */ PERLVAR(I, markstack, I32 *) /* stack_sp locations we're - remembering */ + remembering */ PERLVAR(I, markstack_ptr, I32 *) PERLVAR(I, markstack_max, I32 *) @@ -163,7 +163,7 @@ PERLVAR(I, curcop, COP *) PERLVAR(I, curstack, AV *) /* THE STACK */ PERLVAR(I, curstackinfo, PERL_SI *) /* current stack + context */ PERLVAR(I, mainstack, AV *) /* the stack when nothing funny is - happening */ + happening */ /* memory management */ PERLVAR(I, sv_count, IV) /* how many SV* are currently allocated */ @@ -249,7 +249,7 @@ C<SvPV_nolen> macro. */ PERLVAR(I, na, STRLEN) /* for use in SvPV when length is - Not Applicable */ + Not Applicable */ /* stat stuff */ PERLVAR(I, statcache, Stat_t) /* _ */ @@ -318,7 +318,7 @@ PERLVAR(I, efloatbuf, char *) PERLVAR(I, efloatsize, STRLEN) PERLVARI(I, dumpindent, U16, 4) /* number of blanks per dump - indentation level */ + indentation level */ /* =for apidoc_section $embedding @@ -492,7 +492,7 @@ PERLVAR(I, e_script, SV *) PERLVAR(I, basetime, Time_t) /* $^T */ PERLVARI(I, maxsysfd, I32, MAXSYSFD) - /* top fd to pass to subprocesses */ + /* top fd to pass to subprocesses */ PERLVAR(I, statusvalue, I32) /* $? */ #ifdef VMS PERLVAR(I, statusvalue_vms, U32) @@ -612,12 +612,12 @@ PERLVARI(I, laststype, U16, OP_STAT) PERLVARI(I, laststatval, int, -1) PERLVAR(I, modcount, I32) /* how much op_lvalue()ification in - assignment? */ + assignment? */ /* interpreter atexit processing */ PERLVARI(I, exitlistlen, I32, 0) /* length of same */ PERLVARI(I, exitlist, PerlExitListEntry *, NULL) - /* list of exit functions */ + /* list of exit functions */ /* =for apidoc_section $HV @@ -650,7 +650,7 @@ PERLVAR(I, comppad_name_floor, PADOFFSET)/* start of vars in innermost block */ #ifdef HAVE_INTERP_INTERN PERLVAR(I, sys_intern, struct interp_intern) - /* platform internals */ + /* platform internals */ #endif /* more statics moved here */ @@ -713,7 +713,7 @@ PERLVAR(I, min_intro_pending, PADOFFSET)/* start of vars to introduce */ PERLVAR(I, max_intro_pending, PADOFFSET)/* end of vars to introduce */ PERLVAR(I, padix, PADOFFSET) /* lowest unused index - 1 - in current "register" pad */ + in current "register" pad */ PERLVAR(I, constpadix, PADOFFSET) /* lowest unused for constants */ PERLVAR(I, padix_floor, PADOFFSET) /* how low may inner block reset padix */ @@ -736,7 +736,7 @@ PERLVARI(I, strxfrm_is_behaved, bool, TRUE) /* Assume until proven otherwise that it works */ PERLVARI(I, strxfrm_max_cp, U8, 0) /* Highest collating cp in locale */ PERLVARI(I, collation_standard, bool, TRUE) - /* Assume simple collation */ + /* Assume simple collation */ #endif /* USE_LOCALE_COLLATE */ PERLVARI(I, langinfo_buf, char *, NULL) @@ -795,11 +795,11 @@ PERLVAR(I, srand_called, bool) #ifdef USE_LOCALE_NUMERIC PERLVARI(I, numeric_underlying, bool, TRUE) - /* Assume underlying locale numerics */ + /* Assume underlying locale numerics */ PERLVARI(I, numeric_underlying_is_standard, bool, TRUE) PERLVARI(I, numeric_standard, int, TRUE) - /* Assume C locale numerics */ + /* Assume C locale numerics */ PERLVAR(I, numeric_name, char *) /* Name of current numeric locale */ PERLVAR(I, numeric_radix_sv, SV *) /* The radix separator if not '.' */ @@ -838,12 +838,12 @@ PERLVAR(I, body_arenas, void *) /* pointer to list of body-arenas */ #if defined(USE_ITHREADS) PERLVAR(I, regex_pad, SV **) /* Shortcut into the array of - regex_padav */ + regex_padav */ PERLVAR(I, regex_padav, AV *) /* All regex objects, indexed via the - values in op_pmoffset of pmop. - Entry 0 is an SV whose PV is a - "packed" list of IVs listing - the now-free slots in the array */ + values in op_pmoffset of pmop. + Entry 0 is an SV whose PV is a + "packed" list of IVs listing + the now-free slots in the array */ PERLVAR(I, stashpad, HV **) /* for CopSTASH */ PERLVARI(I, stashpadmax, PADOFFSET, 64) PERLVARI(I, stashpadix, PADOFFSET, 0) @@ -864,7 +864,7 @@ PERLVARI(I, def_layerlist, PerlIO_list_t *, NULL) PERLVARI(I, checkav_save, AV *, NULL) /* save CHECK{}s when compiling */ PERLVARI(I, unitcheckav_save, AV *, NULL) - /* save UNITCHECK{}s when compiling */ + /* save UNITCHECK{}s when compiling */ PERLVARI(I, clocktick, long, 0) /* this many times() ticks in a second */ diff --git a/invlist_inline.h b/invlist_inline.h index f6ac819533..0f24f3d503 100644 --- a/invlist_inline.h +++ b/invlist_inline.h @@ -145,7 +145,7 @@ S_invlist_highest(SV* const invlist) PERL_ARGS_ASSERT_INVLIST_HIGHEST; if (len == 0) { - return 0; + return 0; } array = invlist_array(invlist); @@ -218,8 +218,8 @@ S_invlist_iternext(SV* invlist, UV* start, UV* end) PERL_ARGS_ASSERT_INVLIST_ITERNEXT; if (*pos >= len) { - *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */ - return FALSE; + *pos = (STRLEN) UV_MAX; /* Force iterinit() to be required next time */ + return FALSE; } array = invlist_array(invlist); @@ -227,10 +227,10 @@ S_invlist_iternext(SV* invlist, UV* start, UV* end) *start = array[(*pos)++]; if (*pos >= len) { - *end = UV_MAX; + *end = UV_MAX; } else { - *end = array[(*pos)++] - 1; + *end = array[(*pos)++] - 1; } return TRUE; diff --git a/iperlsys.h b/iperlsys.h index 28091141e6..eaa0a9df22 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -69,7 +69,7 @@ typedef FILE* (*LPStdin)(struct IPerlStdIO*); typedef FILE* (*LPStdout)(struct IPerlStdIO*); typedef FILE* (*LPStderr)(struct IPerlStdIO*); typedef FILE* (*LPOpen)(struct IPerlStdIO*, const char*, - const char*); + const char*); typedef int (*LPClose)(struct IPerlStdIO*, FILE*); typedef int (*LPEof)(struct IPerlStdIO*, FILE*); typedef int (*LPError)(struct IPerlStdIO*, FILE*); @@ -87,12 +87,12 @@ typedef int (*LPUngetc)(struct IPerlStdIO*, int,FILE*); typedef int (*LPFileno)(struct IPerlStdIO*, FILE*); typedef FILE* (*LPFdopen)(struct IPerlStdIO*, int, const char*); typedef FILE* (*LPReopen)(struct IPerlStdIO*, const char*, - const char*, FILE*); + const char*, FILE*); typedef SSize_t (*LPRead)(struct IPerlStdIO*, void*, Size_t, Size_t, FILE *); typedef SSize_t (*LPWrite)(struct IPerlStdIO*, const void*, Size_t, Size_t, FILE *); typedef void (*LPSetBuf)(struct IPerlStdIO*, FILE*, char*); typedef int (*LPSetVBuf)(struct IPerlStdIO*, FILE*, char*, int, - Size_t); + Size_t); typedef void (*LPSetCnt)(struct IPerlStdIO*, FILE*, int); #ifndef NETWARE @@ -103,16 +103,16 @@ typedef void (*LPSetPtr)(struct IPerlStdIO*, FILE*, STDCHAR*, int); typedef void (*LPSetlinebuf)(struct IPerlStdIO*, FILE*); typedef int (*LPPrintf)(struct IPerlStdIO*, FILE*, const char*, - ...); + ...); typedef int (*LPVprintf)(struct IPerlStdIO*, FILE*, const char*, - va_list); + va_list); typedef Off_t (*LPTell)(struct IPerlStdIO*, FILE*); typedef int (*LPSeek)(struct IPerlStdIO*, FILE*, Off_t, int); typedef void (*LPRewind)(struct IPerlStdIO*, FILE*); typedef FILE* (*LPTmpfile)(struct IPerlStdIO*); typedef int (*LPGetpos)(struct IPerlStdIO*, FILE*, Fpos_t*); typedef int (*LPSetpos)(struct IPerlStdIO*, FILE*, - const Fpos_t*); + const Fpos_t*); typedef void (*LPInit)(struct IPerlStdIO*); typedef void (*LPInitOSExtras)(struct IPerlStdIO*); typedef FILE* (*LPFdupopen)(struct IPerlStdIO*, FILE*); @@ -202,84 +202,84 @@ struct IPerlStdIOInfo /* Now take FILE * via function table */ #define PerlSIO_stdin \ - (*PL_StdIO->pStdin)(PL_StdIO) + (*PL_StdIO->pStdin)(PL_StdIO) #define PerlSIO_stdout \ - (*PL_StdIO->pStdout)(PL_StdIO) + (*PL_StdIO->pStdout)(PL_StdIO) #define PerlSIO_stderr \ - (*PL_StdIO->pStderr)(PL_StdIO) + (*PL_StdIO->pStderr)(PL_StdIO) #define PerlSIO_fopen(x,y) \ - (*PL_StdIO->pOpen)(PL_StdIO, (x),(y)) + (*PL_StdIO->pOpen)(PL_StdIO, (x),(y)) #define PerlSIO_fclose(f) \ - (*PL_StdIO->pClose)(PL_StdIO, (f)) + (*PL_StdIO->pClose)(PL_StdIO, (f)) #define PerlSIO_feof(f) \ - (*PL_StdIO->pEof)(PL_StdIO, (f)) + (*PL_StdIO->pEof)(PL_StdIO, (f)) #define PerlSIO_ferror(f) \ - (*PL_StdIO->pError)(PL_StdIO, (f)) + (*PL_StdIO->pError)(PL_StdIO, (f)) #define PerlSIO_clearerr(f) \ - (*PL_StdIO->pClearerr)(PL_StdIO, (f)) + (*PL_StdIO->pClearerr)(PL_StdIO, (f)) #define PerlSIO_fgetc(f) \ - (*PL_StdIO->pGetc)(PL_StdIO, (f)) + (*PL_StdIO->pGetc)(PL_StdIO, (f)) #define PerlSIO_get_base(f) \ - (*PL_StdIO->pGetBase)(PL_StdIO, (f)) + (*PL_StdIO->pGetBase)(PL_StdIO, (f)) #define PerlSIO_get_bufsiz(f) \ - (*PL_StdIO->pGetBufsiz)(PL_StdIO, (f)) + (*PL_StdIO->pGetBufsiz)(PL_StdIO, (f)) #define PerlSIO_get_cnt(f) \ - (*PL_StdIO->pGetCnt)(PL_StdIO, (f)) + (*PL_StdIO->pGetCnt)(PL_StdIO, (f)) #define PerlSIO_get_ptr(f) \ - (*PL_StdIO->pGetPtr)(PL_StdIO, (f)) + (*PL_StdIO->pGetPtr)(PL_StdIO, (f)) #define PerlSIO_fputc(c,f) \ - (*PL_StdIO->pPutc)(PL_StdIO, (c),(f)) + (*PL_StdIO->pPutc)(PL_StdIO, (c),(f)) #define PerlSIO_fputs(s,f) \ - (*PL_StdIO->pPuts)(PL_StdIO, (s),(f)) + (*PL_StdIO->pPuts)(PL_StdIO, (s),(f)) #define PerlSIO_fflush(f) \ - (*PL_StdIO->pFlush)(PL_StdIO, (f)) + (*PL_StdIO->pFlush)(PL_StdIO, (f)) #define PerlSIO_fgets(s, n, f) \ - (*PL_StdIO->pGets)(PL_StdIO, s, n, (f)) + (*PL_StdIO->pGets)(PL_StdIO, s, n, (f)) #define PerlSIO_ungetc(c,f) \ - (*PL_StdIO->pUngetc)(PL_StdIO, (c),(f)) + (*PL_StdIO->pUngetc)(PL_StdIO, (c),(f)) #define PerlSIO_fileno(f) \ - (*PL_StdIO->pFileno)(PL_StdIO, (f)) + (*PL_StdIO->pFileno)(PL_StdIO, (f)) #define PerlSIO_fdopen(f, s) \ - (*PL_StdIO->pFdopen)(PL_StdIO, (f),(s)) + (*PL_StdIO->pFdopen)(PL_StdIO, (f),(s)) #define PerlSIO_freopen(p, m, f) \ - (*PL_StdIO->pReopen)(PL_StdIO, (p), (m), (f)) + (*PL_StdIO->pReopen)(PL_StdIO, (p), (m), (f)) #define PerlSIO_fread(buf,sz,count,f) \ - (*PL_StdIO->pRead)(PL_StdIO, (buf), (sz), (count), (f)) + (*PL_StdIO->pRead)(PL_StdIO, (buf), (sz), (count), (f)) #define PerlSIO_fwrite(buf,sz,count,f) \ - (*PL_StdIO->pWrite)(PL_StdIO, (buf), (sz), (count), (f)) + (*PL_StdIO->pWrite)(PL_StdIO, (buf), (sz), (count), (f)) #define PerlSIO_setbuf(f,b) \ - (*PL_StdIO->pSetBuf)(PL_StdIO, (f), (b)) + (*PL_StdIO->pSetBuf)(PL_StdIO, (f), (b)) #define PerlSIO_setvbuf(f,b,t,s) \ - (*PL_StdIO->pSetVBuf)(PL_StdIO, (f),(b),(t),(s)) + (*PL_StdIO->pSetVBuf)(PL_StdIO, (f),(b),(t),(s)) #define PerlSIO_set_cnt(f,c) \ - (*PL_StdIO->pSetCnt)(PL_StdIO, (f), (c)) + (*PL_StdIO->pSetCnt)(PL_StdIO, (f), (c)) #define PerlSIO_set_ptr(f,p) \ - (*PL_StdIO->pSetPtr)(PL_StdIO, (f), (p)) + (*PL_StdIO->pSetPtr)(PL_StdIO, (f), (p)) #define PerlSIO_setlinebuf(f) \ - (*PL_StdIO->pSetlinebuf)(PL_StdIO, (f)) + (*PL_StdIO->pSetlinebuf)(PL_StdIO, (f)) #define PerlSIO_printf Perl_fprintf_nocontext #define PerlSIO_stdoutf Perl_printf_nocontext #define PerlSIO_vprintf(f,fmt,a) \ - (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a) + (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a) #define PerlSIO_ftell(f) \ - (*PL_StdIO->pTell)(PL_StdIO, (f)) + (*PL_StdIO->pTell)(PL_StdIO, (f)) #define PerlSIO_fseek(f,o,w) \ - (*PL_StdIO->pSeek)(PL_StdIO, (f),(o),(w)) + (*PL_StdIO->pSeek)(PL_StdIO, (f),(o),(w)) #define PerlSIO_fgetpos(f,p) \ - (*PL_StdIO->pGetpos)(PL_StdIO, (f),(p)) + (*PL_StdIO->pGetpos)(PL_StdIO, (f),(p)) #define PerlSIO_fsetpos(f,p) \ - (*PL_StdIO->pSetpos)(PL_StdIO, (f),(p)) + (*PL_StdIO->pSetpos)(PL_StdIO, (f),(p)) #define PerlSIO_rewind(f) \ - (*PL_StdIO->pRewind)(PL_StdIO, (f)) + (*PL_StdIO->pRewind)(PL_StdIO, (f)) #define PerlSIO_tmpfile() \ - (*PL_StdIO->pTmpfile)(PL_StdIO) + (*PL_StdIO->pTmpfile)(PL_StdIO) #define PerlSIO_init() \ - (*PL_StdIO->pInit)(PL_StdIO) + (*PL_StdIO->pInit)(PL_StdIO) #undef init_os_extras #define init_os_extras() \ - (*PL_StdIO->pInitOSExtras)(PL_StdIO) + (*PL_StdIO->pInitOSExtras)(PL_StdIO) #define PerlSIO_fdupopen(f) \ - (*PL_StdIO->pFdupopen)(PL_StdIO, (f)) + (*PL_StdIO->pFdupopen)(PL_StdIO, (f)) #else /* PERL_IMPLICIT_SYS */ @@ -408,28 +408,28 @@ struct IPerlDirInfo }; #define PerlDir_mkdir(name, mode) \ - (*PL_Dir->pMakedir)(PL_Dir, (name), (mode)) + (*PL_Dir->pMakedir)(PL_Dir, (name), (mode)) #define PerlDir_chdir(name) \ - (*PL_Dir->pChdir)(PL_Dir, (name)) + (*PL_Dir->pChdir)(PL_Dir, (name)) #define PerlDir_rmdir(name) \ - (*PL_Dir->pRmdir)(PL_Dir, (name)) + (*PL_Dir->pRmdir)(PL_Dir, (name)) #define PerlDir_close(dir) \ - (*PL_Dir->pClose)(PL_Dir, (dir)) + (*PL_Dir->pClose)(PL_Dir, (dir)) #define PerlDir_open(name) \ - (*PL_Dir->pOpen)(PL_Dir, (name)) + (*PL_Dir->pOpen)(PL_Dir, (name)) #define PerlDir_read(dir) \ - (*PL_Dir->pRead)(PL_Dir, (dir)) + (*PL_Dir->pRead)(PL_Dir, (dir)) #define PerlDir_rewind(dir) \ - (*PL_Dir->pRewind)(PL_Dir, (dir)) + (*PL_Dir->pRewind)(PL_Dir, (dir)) #define PerlDir_seek(dir, loc) \ - (*PL_Dir->pSeek)(PL_Dir, (dir), (loc)) + (*PL_Dir->pSeek)(PL_Dir, (dir), (loc)) #define PerlDir_tell(dir) \ - (*PL_Dir->pTell)(PL_Dir, (dir)) + (*PL_Dir->pTell)(PL_Dir, (dir)) #ifdef WIN32 #define PerlDir_mapA(dir) \ - (*PL_Dir->pMapPathA)(PL_Dir, (dir)) + (*PL_Dir->pMapPathA)(PL_Dir, (dir)) #define PerlDir_mapW(dir) \ - (*PL_Dir->pMapPathW)(PL_Dir, (dir)) + (*PL_Dir->pMapPathW)(PL_Dir, (dir)) #endif #else /* PERL_IMPLICIT_SYS */ @@ -466,7 +466,7 @@ struct IPerlEnvInfo; typedef char* (*LPEnvGetenv)(struct IPerlEnv*, const char*); typedef int (*LPEnvPutenv)(struct IPerlEnv*, const char*); typedef char* (*LPEnvGetenv_len)(struct IPerlEnv*, - const char *varname, unsigned long *len); + const char *varname, unsigned long *len); typedef int (*LPEnvUname)(struct IPerlEnv*, struct utsname *name); typedef void (*LPEnvClearenv)(struct IPerlEnv*); typedef void* (*LPEnvGetChildenv)(struct IPerlEnv*); @@ -476,16 +476,16 @@ typedef void (*LPEnvFreeChilddir)(struct IPerlEnv*, char* dir); #ifdef HAS_ENVGETENV typedef char* (*LPENVGetenv)(struct IPerlEnv*, const char *varname); typedef char* (*LPENVGetenv_len)(struct IPerlEnv*, - const char *varname, unsigned long *len); + const char *varname, unsigned long *len); #endif #ifdef WIN32 typedef unsigned long (*LPEnvOsID)(struct IPerlEnv*); typedef char* (*LPEnvLibPath)(struct IPerlEnv*, WIN32_NO_REGISTRY_M_(const char*) - STRLEN *const len); + STRLEN *const len); typedef char* (*LPEnvSiteLibPath)(struct IPerlEnv*, const char*, - STRLEN *const len); + STRLEN *const len); typedef char* (*LPEnvVendorLibPath)(struct IPerlEnv*, const char*, - STRLEN *const len); + STRLEN *const len); typedef void (*LPEnvGetChildIO)(struct IPerlEnv*, child_IO_table*); #endif @@ -520,45 +520,45 @@ struct IPerlEnvInfo }; #define PerlEnv_putenv(str) \ - (*PL_Env->pPutenv)(PL_Env,(str)) + (*PL_Env->pPutenv)(PL_Env,(str)) #define PerlEnv_getenv(str) \ - (*PL_Env->pGetenv)(PL_Env,(str)) + (*PL_Env->pGetenv)(PL_Env,(str)) #define PerlEnv_getenv_len(str,l) \ - (*PL_Env->pGetenv_len)(PL_Env,(str), (l)) + (*PL_Env->pGetenv_len)(PL_Env,(str), (l)) #define PerlEnv_clearenv() \ - (*PL_Env->pClearenv)(PL_Env) + (*PL_Env->pClearenv)(PL_Env) #define PerlEnv_get_childenv() \ - (*PL_Env->pGetChildenv)(PL_Env) + (*PL_Env->pGetChildenv)(PL_Env) #define PerlEnv_free_childenv(e) \ - (*PL_Env->pFreeChildenv)(PL_Env, (e)) + (*PL_Env->pFreeChildenv)(PL_Env, (e)) #define PerlEnv_get_childdir() \ - (*PL_Env->pGetChilddir)(PL_Env) + (*PL_Env->pGetChilddir)(PL_Env) #define PerlEnv_free_childdir(d) \ - (*PL_Env->pFreeChilddir)(PL_Env, (d)) + (*PL_Env->pFreeChilddir)(PL_Env, (d)) #ifdef HAS_ENVGETENV # define PerlEnv_ENVgetenv(str) \ - (*PL_Env->pENVGetenv)(PL_Env,(str)) + (*PL_Env->pENVGetenv)(PL_Env,(str)) # define PerlEnv_ENVgetenv_len(str,l) \ - (*PL_Env->pENVGetenv_len)(PL_Env,(str), (l)) + (*PL_Env->pENVGetenv_len)(PL_Env,(str), (l)) #else # define PerlEnv_ENVgetenv(str) \ - PerlEnv_getenv((str)) + PerlEnv_getenv((str)) # define PerlEnv_ENVgetenv_len(str,l) \ - PerlEnv_getenv_len((str),(l)) + PerlEnv_getenv_len((str),(l)) #endif #define PerlEnv_uname(name) \ - (*PL_Env->pEnvUname)(PL_Env,(name)) + (*PL_Env->pEnvUname)(PL_Env,(name)) #ifdef WIN32 #define PerlEnv_os_id() \ - (*PL_Env->pEnvOsID)(PL_Env) + (*PL_Env->pEnvOsID)(PL_Env) #define PerlEnv_lib_path(str, lenp) \ - (*PL_Env->pLibPath)(PL_Env,WIN32_NO_REGISTRY_M_(str)(lenp)) + (*PL_Env->pLibPath)(PL_Env,WIN32_NO_REGISTRY_M_(str)(lenp)) #define PerlEnv_sitelib_path(str, lenp) \ - (*PL_Env->pSiteLibPath)(PL_Env,(str),(lenp)) + (*PL_Env->pSiteLibPath)(PL_Env,(str),(lenp)) #define PerlEnv_vendorlib_path(str, lenp) \ - (*PL_Env->pVendorLibPath)(PL_Env,(str),(lenp)) + (*PL_Env->pVendorLibPath)(PL_Env,(str),(lenp)) #define PerlEnv_get_child_IO(ptr) \ - (*PL_Env->pGetChildIO)(PL_Env, ptr) + (*PL_Env->pGetChildIO)(PL_Env, ptr) #endif #else /* below is ! PERL_IMPLICIT_SYS */ @@ -620,7 +620,7 @@ struct IPerlLIOInfo; typedef int (*LPLIOAccess)(struct IPerlLIO*, const char*, int); typedef int (*LPLIOChmod)(struct IPerlLIO*, const char*, int); typedef int (*LPLIOChown)(struct IPerlLIO*, const char*, uid_t, - gid_t); + gid_t); typedef int (*LPLIOChsize)(struct IPerlLIO*, int, Off_t); typedef int (*LPLIOClose)(struct IPerlLIO*, int); typedef int (*LPLIODup)(struct IPerlLIO*, int); @@ -628,34 +628,34 @@ typedef int (*LPLIODup2)(struct IPerlLIO*, int, int); typedef int (*LPLIOFlock)(struct IPerlLIO*, int, int); typedef int (*LPLIOFileStat)(struct IPerlLIO*, int, Stat_t*); typedef int (*LPLIOIOCtl)(struct IPerlLIO*, int, unsigned int, - char*); + char*); typedef int (*LPLIOIsatty)(struct IPerlLIO*, int); typedef int (*LPLIOLink)(struct IPerlLIO*, const char*, - const char *); + const char *); typedef Off_t (*LPLIOLseek)(struct IPerlLIO*, int, Off_t, int); typedef int (*LPLIOLstat)(struct IPerlLIO*, const char*, - Stat_t*); + Stat_t*); typedef char* (*LPLIOMktemp)(struct IPerlLIO*, char*); typedef int (*LPLIOOpen)(struct IPerlLIO*, const char*, int); typedef int (*LPLIOOpen3)(struct IPerlLIO*, const char*, int, int); typedef int (*LPLIORead)(struct IPerlLIO*, int, void*, unsigned int); typedef int (*LPLIORename)(struct IPerlLIO*, const char*, - const char*); + const char*); #ifdef NETWARE typedef int (*LPLIOSetmode)(struct IPerlLIO*, FILE*, int); #else typedef int (*LPLIOSetmode)(struct IPerlLIO*, int, int); #endif /* NETWARE */ typedef int (*LPLIONameStat)(struct IPerlLIO*, const char*, - Stat_t*); + Stat_t*); typedef char* (*LPLIOTmpnam)(struct IPerlLIO*, char*); typedef int (*LPLIOUmask)(struct IPerlLIO*, int); typedef int (*LPLIOUnlink)(struct IPerlLIO*, const char*); typedef int (*LPLIOUtime)(struct IPerlLIO*, const char*, struct utimbuf*); typedef int (*LPLIOWrite)(struct IPerlLIO*, int, const void*, - unsigned int); + unsigned int); typedef int (*LPLIOSymLink)(struct IPerlLIO*, const char*, - const char *); + const char *); typedef int (*LPLIOReadLink)(struct IPerlLIO*, const char*, char *, size_t); @@ -698,61 +698,61 @@ struct IPerlLIOInfo }; #define PerlLIO_access(file, mode) \ - (*PL_LIO->pAccess)(PL_LIO, (file), (mode)) + (*PL_LIO->pAccess)(PL_LIO, (file), (mode)) #define PerlLIO_chmod(file, mode) \ - (*PL_LIO->pChmod)(PL_LIO, (file), (mode)) + (*PL_LIO->pChmod)(PL_LIO, (file), (mode)) #define PerlLIO_chown(file, owner, group) \ - (*PL_LIO->pChown)(PL_LIO, (file), (owner), (group)) + (*PL_LIO->pChown)(PL_LIO, (file), (owner), (group)) #define PerlLIO_chsize(fd, size) \ - (*PL_LIO->pChsize)(PL_LIO, (fd), (size)) + (*PL_LIO->pChsize)(PL_LIO, (fd), (size)) #define PerlLIO_close(fd) \ - (*PL_LIO->pClose)(PL_LIO, (fd)) + (*PL_LIO->pClose)(PL_LIO, (fd)) #define PerlLIO_dup(fd) \ - (*PL_LIO->pDup)(PL_LIO, (fd)) + (*PL_LIO->pDup)(PL_LIO, (fd)) #define PerlLIO_dup2(fd1, fd2) \ - (*PL_LIO->pDup2)(PL_LIO, (fd1), (fd2)) + (*PL_LIO->pDup2)(PL_LIO, (fd1), (fd2)) #define PerlLIO_flock(fd, op) \ - (*PL_LIO->pFlock)(PL_LIO, (fd), (op)) + (*PL_LIO->pFlock)(PL_LIO, (fd), (op)) #define PerlLIO_fstat(fd, buf) \ - (*PL_LIO->pFileStat)(PL_LIO, (fd), (buf)) + (*PL_LIO->pFileStat)(PL_LIO, (fd), (buf)) #define PerlLIO_ioctl(fd, u, buf) \ - (*PL_LIO->pIOCtl)(PL_LIO, (fd), (u), (buf)) + (*PL_LIO->pIOCtl)(PL_LIO, (fd), (u), (buf)) #define PerlLIO_isatty(fd) \ - (*PL_LIO->pIsatty)(PL_LIO, (fd)) + (*PL_LIO->pIsatty)(PL_LIO, (fd)) #define PerlLIO_link(oldname, newname) \ - (*PL_LIO->pLink)(PL_LIO, (oldname), (newname)) + (*PL_LIO->pLink)(PL_LIO, (oldname), (newname)) #define PerlLIO_symlink(oldname, newname) \ (*PL_LIO->pSymLink)(PL_LIO, (oldname), (newname)) #define PerlLIO_readlink(path, buf, bufsiz) \ (*PL_LIO->pReadLink)(PL_LIO, (path), (buf), (bufsiz)) #define PerlLIO_lseek(fd, offset, mode) \ - (*PL_LIO->pLseek)(PL_LIO, (fd), (offset), (mode)) + (*PL_LIO->pLseek)(PL_LIO, (fd), (offset), (mode)) #define PerlLIO_lstat(name, buf) \ - (*PL_LIO->pLstat)(PL_LIO, (name), (buf)) + (*PL_LIO->pLstat)(PL_LIO, (name), (buf)) #define PerlLIO_mktemp(file) \ - (*PL_LIO->pMktemp)(PL_LIO, (file)) + (*PL_LIO->pMktemp)(PL_LIO, (file)) #define PerlLIO_open(file, flag) \ - (*PL_LIO->pOpen)(PL_LIO, (file), (flag)) + (*PL_LIO->pOpen)(PL_LIO, (file), (flag)) #define PerlLIO_open3(file, flag, perm) \ - (*PL_LIO->pOpen3)(PL_LIO, (file), (flag), (perm)) + (*PL_LIO->pOpen3)(PL_LIO, (file), (flag), (perm)) #define PerlLIO_read(fd, buf, count) \ - (*PL_LIO->pRead)(PL_LIO, (fd), (buf), (count)) + (*PL_LIO->pRead)(PL_LIO, (fd), (buf), (count)) #define PerlLIO_rename(oname, newname) \ - (*PL_LIO->pRename)(PL_LIO, (oname), (newname)) + (*PL_LIO->pRename)(PL_LIO, (oname), (newname)) #define PerlLIO_setmode(fd, mode) \ - (*PL_LIO->pSetmode)(PL_LIO, (fd), (mode)) + (*PL_LIO->pSetmode)(PL_LIO, (fd), (mode)) #define PerlLIO_stat(name, buf) \ - (*PL_LIO->pNameStat)(PL_LIO, (name), (buf)) + (*PL_LIO->pNameStat)(PL_LIO, (name), (buf)) #define PerlLIO_tmpnam(str) \ - (*PL_LIO->pTmpnam)(PL_LIO, (str)) + (*PL_LIO->pTmpnam)(PL_LIO, (str)) #define PerlLIO_umask(mode) \ - (*PL_LIO->pUmask)(PL_LIO, (mode)) + (*PL_LIO->pUmask)(PL_LIO, (mode)) #define PerlLIO_unlink(file) \ - (*PL_LIO->pUnlink)(PL_LIO, (file)) + (*PL_LIO->pUnlink)(PL_LIO, (file)) #define PerlLIO_utime(file, time) \ - (*PL_LIO->pUtime)(PL_LIO, (file), (time)) + (*PL_LIO->pUtime)(PL_LIO, (file), (time)) #define PerlLIO_write(fd, buf, count) \ - (*PL_LIO->pWrite)(PL_LIO, (fd), (buf), (count)) + (*PL_LIO->pWrite)(PL_LIO, (fd), (buf), (count)) #else /* PERL_IMPLICIT_SYS */ @@ -833,72 +833,72 @@ struct IPerlMemInfo /* Interpreter specific memory macros */ #define PerlMem_malloc(size) \ - (*PL_Mem->pMalloc)(PL_Mem, (size)) + (*PL_Mem->pMalloc)(PL_Mem, (size)) #define PerlMem_realloc(buf, size) \ - (*PL_Mem->pRealloc)(PL_Mem, (buf), (size)) + (*PL_Mem->pRealloc)(PL_Mem, (buf), (size)) #define PerlMem_free(buf) \ - (*PL_Mem->pFree)(PL_Mem, (buf)) + (*PL_Mem->pFree)(PL_Mem, (buf)) #define PerlMem_calloc(num, size) \ - (*PL_Mem->pCalloc)(PL_Mem, (num), (size)) + (*PL_Mem->pCalloc)(PL_Mem, (num), (size)) #define PerlMem_get_lock() \ - (*PL_Mem->pGetLock)(PL_Mem) + (*PL_Mem->pGetLock)(PL_Mem) #define PerlMem_free_lock() \ - (*PL_Mem->pFreeLock)(PL_Mem) + (*PL_Mem->pFreeLock)(PL_Mem) #define PerlMem_is_locked() \ - (*PL_Mem->pIsLocked)(PL_Mem) + (*PL_Mem->pIsLocked)(PL_Mem) /* Shared memory macros */ #ifdef NETWARE #define PerlMemShared_malloc(size) \ - (*PL_Mem->pMalloc)(PL_Mem, (size)) + (*PL_Mem->pMalloc)(PL_Mem, (size)) #define PerlMemShared_realloc(buf, size) \ - (*PL_Mem->pRealloc)(PL_Mem, (buf), (size)) + (*PL_Mem->pRealloc)(PL_Mem, (buf), (size)) #define PerlMemShared_free(buf) \ - (*PL_Mem->pFree)(PL_Mem, (buf)) + (*PL_Mem->pFree)(PL_Mem, (buf)) #define PerlMemShared_calloc(num, size) \ - (*PL_Mem->pCalloc)(PL_Mem, (num), (size)) + (*PL_Mem->pCalloc)(PL_Mem, (num), (size)) #define PerlMemShared_get_lock() \ - (*PL_Mem->pGetLock)(PL_Mem) + (*PL_Mem->pGetLock)(PL_Mem) #define PerlMemShared_free_lock() \ - (*PL_Mem->pFreeLock)(PL_Mem) + (*PL_Mem->pFreeLock)(PL_Mem) #define PerlMemShared_is_locked() \ - (*PL_Mem->pIsLocked)(PL_Mem) + (*PL_Mem->pIsLocked)(PL_Mem) #else #define PerlMemShared_malloc(size) \ - (*PL_MemShared->pMalloc)(PL_MemShared, (size)) + (*PL_MemShared->pMalloc)(PL_MemShared, (size)) #define PerlMemShared_realloc(buf, size) \ - (*PL_MemShared->pRealloc)(PL_MemShared, (buf), (size)) + (*PL_MemShared->pRealloc)(PL_MemShared, (buf), (size)) #define PerlMemShared_free(buf) \ - (*PL_MemShared->pFree)(PL_MemShared, (buf)) + (*PL_MemShared->pFree)(PL_MemShared, (buf)) #define PerlMemShared_calloc(num, size) \ - (*PL_MemShared->pCalloc)(PL_MemShared, (num), (size)) + (*PL_MemShared->pCalloc)(PL_MemShared, (num), (size)) #define PerlMemShared_get_lock() \ - (*PL_MemShared->pGetLock)(PL_MemShared) + (*PL_MemShared->pGetLock)(PL_MemShared) #define PerlMemShared_free_lock() \ - (*PL_MemShared->pFreeLock)(PL_MemShared) + (*PL_MemShared->pFreeLock)(PL_MemShared) #define PerlMemShared_is_locked() \ - (*PL_MemShared->pIsLocked)(PL_MemShared) + (*PL_MemShared->pIsLocked)(PL_MemShared) #endif /* Parse tree memory macros */ #define PerlMemParse_malloc(size) \ - (*PL_MemParse->pMalloc)(PL_MemParse, (size)) + (*PL_MemParse->pMalloc)(PL_MemParse, (size)) #define PerlMemParse_realloc(buf, size) \ - (*PL_MemParse->pRealloc)(PL_MemParse, (buf), (size)) + (*PL_MemParse->pRealloc)(PL_MemParse, (buf), (size)) #define PerlMemParse_free(buf) \ - (*PL_MemParse->pFree)(PL_MemParse, (buf)) + (*PL_MemParse->pFree)(PL_MemParse, (buf)) #define PerlMemParse_calloc(num, size) \ - (*PL_MemParse->pCalloc)(PL_MemParse, (num), (size)) + (*PL_MemParse->pCalloc)(PL_MemParse, (num), (size)) #define PerlMemParse_get_lock() \ - (*PL_MemParse->pGetLock)(PL_MemParse) + (*PL_MemParse->pGetLock)(PL_MemParse) #define PerlMemParse_free_lock() \ - (*PL_MemParse->pFreeLock)(PL_MemParse) + (*PL_MemParse->pFreeLock)(PL_MemParse) #define PerlMemParse_is_locked() \ - (*PL_MemParse->pIsLocked)(PL_MemParse) + (*PL_MemParse->pIsLocked)(PL_MemParse) #else /* PERL_IMPLICIT_SYS */ @@ -948,18 +948,18 @@ struct IPerlProc; struct IPerlProcInfo; typedef void (*LPProcAbort)(struct IPerlProc*); typedef char* (*LPProcCrypt)(struct IPerlProc*, const char*, - const char*); + const char*); typedef void (*LPProcExit)(struct IPerlProc*, int) - __attribute__noreturn__; + __attribute__noreturn__; typedef void (*LPProc_Exit)(struct IPerlProc*, int) - __attribute__noreturn__; + __attribute__noreturn__; typedef int (*LPProcExecl)(struct IPerlProc*, const char*, - const char*, const char*, const char*, - const char*); + const char*, const char*, const char*, + const char*); typedef int (*LPProcExecv)(struct IPerlProc*, const char*, - const char*const*); + const char*const*); typedef int (*LPProcExecvp)(struct IPerlProc*, const char*, - const char*const*); + const char*const*); typedef Uid_t (*LPProcGetuid)(struct IPerlProc*); typedef Uid_t (*LPProcGeteuid)(struct IPerlProc*); typedef Gid_t (*LPProcGetgid)(struct IPerlProc*); @@ -969,9 +969,9 @@ typedef int (*LPProcKill)(struct IPerlProc*, int, int); typedef int (*LPProcKillpg)(struct IPerlProc*, int, int); typedef int (*LPProcPauseProc)(struct IPerlProc*); typedef PerlIO* (*LPProcPopen)(struct IPerlProc*, const char*, - const char*); + const char*); typedef PerlIO* (*LPProcPopenList)(struct IPerlProc*, const char*, - IV narg, SV **args); + IV narg, SV **args); typedef int (*LPProcPclose)(struct IPerlProc*, PerlIO*); typedef int (*LPProcPipe)(struct IPerlProc*, int*); typedef int (*LPProcSetuid)(struct IPerlProc*, uid_t); @@ -986,13 +986,13 @@ typedef int (*LPProcGetpid)(struct IPerlProc*); #ifdef WIN32 typedef void* (*LPProcDynaLoader)(struct IPerlProc*, const char*); typedef void (*LPProcGetOSError)(struct IPerlProc*, - SV* sv, DWORD dwErr); + SV* sv, DWORD dwErr); typedef int (*LPProcSpawnvp)(struct IPerlProc*, int, const char*, - const char*const*); + const char*const*); #endif typedef int (*LPProcLastHost)(struct IPerlProc*); typedef int (*LPProcGetTimeOfDay)(struct IPerlProc*, - struct timeval*, void*); + struct timeval*, void*); struct IPerlProc { @@ -1040,76 +1040,76 @@ struct IPerlProcInfo }; #define PerlProc_abort() \ - (*PL_Proc->pAbort)(PL_Proc) + (*PL_Proc->pAbort)(PL_Proc) #define PerlProc_crypt(c,s) \ - (*PL_Proc->pCrypt)(PL_Proc, (c), (s)) + (*PL_Proc->pCrypt)(PL_Proc, (c), (s)) #define PerlProc_exit(s) \ - (*PL_Proc->pExit)(PL_Proc, (s)) + (*PL_Proc->pExit)(PL_Proc, (s)) #define PerlProc__exit(s) \ - (*PL_Proc->p_Exit)(PL_Proc, (s)) + (*PL_Proc->p_Exit)(PL_Proc, (s)) #define PerlProc_execl(c, w, x, y, z) \ - (*PL_Proc->pExecl)(PL_Proc, (c), (w), (x), (y), (z)) + (*PL_Proc->pExecl)(PL_Proc, (c), (w), (x), (y), (z)) #define PerlProc_execv(c, a) \ - (*PL_Proc->pExecv)(PL_Proc, (c), (a)) + (*PL_Proc->pExecv)(PL_Proc, (c), (a)) #define PerlProc_execvp(c, a) \ - (*PL_Proc->pExecvp)(PL_Proc, (c), (a)) + (*PL_Proc->pExecvp)(PL_Proc, (c), (a)) #define PerlProc_getuid() \ - (*PL_Proc->pGetuid)(PL_Proc) + (*PL_Proc->pGetuid)(PL_Proc) #define PerlProc_geteuid() \ - (*PL_Proc->pGeteuid)(PL_Proc) + (*PL_Proc->pGeteuid)(PL_Proc) #define PerlProc_getgid() \ - (*PL_Proc->pGetgid)(PL_Proc) + (*PL_Proc->pGetgid)(PL_Proc) #define PerlProc_getegid() \ - (*PL_Proc->pGetegid)(PL_Proc) + (*PL_Proc->pGetegid)(PL_Proc) #define PerlProc_getlogin() \ - (*PL_Proc->pGetlogin)(PL_Proc) + (*PL_Proc->pGetlogin)(PL_Proc) #define PerlProc_kill(i, a) \ - (*PL_Proc->pKill)(PL_Proc, (i), (a)) + (*PL_Proc->pKill)(PL_Proc, (i), (a)) #define PerlProc_killpg(i, a) \ - (*PL_Proc->pKillpg)(PL_Proc, (i), (a)) + (*PL_Proc->pKillpg)(PL_Proc, (i), (a)) #define PerlProc_pause() \ - (*PL_Proc->pPauseProc)(PL_Proc) + (*PL_Proc->pPauseProc)(PL_Proc) #define PerlProc_popen(c, m) \ - (*PL_Proc->pPopen)(PL_Proc, (c), (m)) + (*PL_Proc->pPopen)(PL_Proc, (c), (m)) #define PerlProc_popen_list(m, n, a) \ - (*PL_Proc->pPopenList)(PL_Proc, (m), (n), (a)) + (*PL_Proc->pPopenList)(PL_Proc, (m), (n), (a)) #define PerlProc_pclose(f) \ - (*PL_Proc->pPclose)(PL_Proc, (f)) + (*PL_Proc->pPclose)(PL_Proc, (f)) #define PerlProc_pipe(fd) \ - (*PL_Proc->pPipe)(PL_Proc, (fd)) + (*PL_Proc->pPipe)(PL_Proc, (fd)) #define PerlProc_setuid(u) \ - (*PL_Proc->pSetuid)(PL_Proc, (u)) + (*PL_Proc->pSetuid)(PL_Proc, (u)) #define PerlProc_setgid(g) \ - (*PL_Proc->pSetgid)(PL_Proc, (g)) + (*PL_Proc->pSetgid)(PL_Proc, (g)) #define PerlProc_sleep(t) \ - (*PL_Proc->pSleep)(PL_Proc, (t)) + (*PL_Proc->pSleep)(PL_Proc, (t)) #define PerlProc_times(t) \ - (*PL_Proc->pTimes)(PL_Proc, (t)) + (*PL_Proc->pTimes)(PL_Proc, (t)) #define PerlProc_wait(t) \ - (*PL_Proc->pWait)(PL_Proc, (t)) + (*PL_Proc->pWait)(PL_Proc, (t)) #define PerlProc_waitpid(p,s,f) \ - (*PL_Proc->pWaitpid)(PL_Proc, (p), (s), (f)) + (*PL_Proc->pWaitpid)(PL_Proc, (p), (s), (f)) #define PerlProc_signal(n, h) \ - (*PL_Proc->pSignal)(PL_Proc, (n), (h)) + (*PL_Proc->pSignal)(PL_Proc, (n), (h)) #define PerlProc_fork() \ - (*PL_Proc->pFork)(PL_Proc) + (*PL_Proc->pFork)(PL_Proc) #define PerlProc_getpid() \ - (*PL_Proc->pGetpid)(PL_Proc) + (*PL_Proc->pGetpid)(PL_Proc) #define PerlProc_setjmp(b, n) Sigsetjmp((b), (n)) #define PerlProc_longjmp(b, n) Siglongjmp((b), (n)) #ifdef WIN32 #define PerlProc_DynaLoad(f) \ - (*PL_Proc->pDynaLoader)(PL_Proc, (f)) + (*PL_Proc->pDynaLoader)(PL_Proc, (f)) #define PerlProc_GetOSError(s,e) \ - (*PL_Proc->pGetOSError)(PL_Proc, (s), (e)) + (*PL_Proc->pGetOSError)(PL_Proc, (s), (e)) #define PerlProc_spawnvp(m, c, a) \ - (*PL_Proc->pSpawnvp)(PL_Proc, (m), (c), (a)) + (*PL_Proc->pSpawnvp)(PL_Proc, (m), (c), (a)) #endif #define PerlProc_lasthost() \ - (*PL_Proc->pLastHost)(PL_Proc) + (*PL_Proc->pLastHost)(PL_Proc) #define PerlProc_gettimeofday(t,z) \ - (*PL_Proc->pGetTimeOfDay)(PL_Proc,(t),(z)) + (*PL_Proc->pGetTimeOfDay)(PL_Proc,(t),(z)) #else /* PERL_IMPLICIT_SYS */ @@ -1118,7 +1118,7 @@ struct IPerlProcInfo #define PerlProc_exit(s) exit((s)) #define PerlProc__exit(s) _exit((s)) #define PerlProc_execl(c,w,x,y,z) \ - execl((c), (w), (x), (y), (z)) + execl((c), (w), (x), (y), (z)) #define PerlProc_execv(c, a) execv((c), (a)) #define PerlProc_execvp(c, a) execvp((c), (a)) #define PerlProc_getuid() getuid() @@ -1148,11 +1148,11 @@ struct IPerlProcInfo #ifdef WIN32 #define PerlProc_DynaLoad(f) \ - win32_dynaload((f)) + win32_dynaload((f)) #define PerlProc_GetOSError(s,e) \ - win32_str_os_error((s), (e)) + win32_str_os_error((s), (e)) #define PerlProc_spawnvp(m, c, a) \ - win32_spawnvp((m), (c), (a)) + win32_spawnvp((m), (c), (a)) #undef PerlProc_signal #define PerlProc_signal(n, h) win32_signal((n), (h)) #endif @@ -1172,20 +1172,20 @@ typedef u_short (*LPHtons)(struct IPerlSock*, u_short); typedef u_long (*LPNtohl)(struct IPerlSock*, u_long); typedef u_short (*LPNtohs)(struct IPerlSock*, u_short); typedef SOCKET (*LPAccept)(struct IPerlSock*, SOCKET, - struct sockaddr*, int*); + struct sockaddr*, int*); typedef int (*LPBind)(struct IPerlSock*, SOCKET, - const struct sockaddr*, int); + const struct sockaddr*, int); typedef int (*LPConnect)(struct IPerlSock*, SOCKET, - const struct sockaddr*, int); + const struct sockaddr*, int); typedef void (*LPEndhostent)(struct IPerlSock*); typedef void (*LPEndnetent)(struct IPerlSock*); typedef void (*LPEndprotoent)(struct IPerlSock*); typedef void (*LPEndservent)(struct IPerlSock*); typedef int (*LPGethostname)(struct IPerlSock*, char*, int); typedef int (*LPGetpeername)(struct IPerlSock*, SOCKET, - struct sockaddr*, int*); + struct sockaddr*, int*); typedef struct hostent* (*LPGethostbyaddr)(struct IPerlSock*, const char*, - int, int); + int, int); typedef struct hostent* (*LPGethostbyname)(struct IPerlSock*, const char*); typedef struct hostent* (*LPGethostent)(struct IPerlSock*); typedef struct netent* (*LPGetnetbyaddr)(struct IPerlSock*, long, int); @@ -1195,36 +1195,36 @@ typedef struct protoent*(*LPGetprotobyname)(struct IPerlSock*, const char*); typedef struct protoent*(*LPGetprotobynumber)(struct IPerlSock*, int); typedef struct protoent*(*LPGetprotoent)(struct IPerlSock*); typedef struct servent* (*LPGetservbyname)(struct IPerlSock*, const char*, - const char*); + const char*); typedef struct servent* (*LPGetservbyport)(struct IPerlSock*, int, - const char*); + const char*); typedef struct servent* (*LPGetservent)(struct IPerlSock*); typedef int (*LPGetsockname)(struct IPerlSock*, SOCKET, - struct sockaddr*, int*); + struct sockaddr*, int*); typedef int (*LPGetsockopt)(struct IPerlSock*, SOCKET, int, int, - char*, int*); + char*, int*); typedef unsigned long (*LPInetAddr)(struct IPerlSock*, const char*); typedef char* (*LPInetNtoa)(struct IPerlSock*, struct in_addr); typedef int (*LPListen)(struct IPerlSock*, SOCKET, int); typedef int (*LPRecv)(struct IPerlSock*, SOCKET, char*, int, int); typedef int (*LPRecvfrom)(struct IPerlSock*, SOCKET, char*, int, - int, struct sockaddr*, int*); + int, struct sockaddr*, int*); typedef int (*LPSelect)(struct IPerlSock*, int, char*, char*, - char*, const struct timeval*); + char*, const struct timeval*); typedef int (*LPSend)(struct IPerlSock*, SOCKET, const char*, int, - int); + int); typedef int (*LPSendto)(struct IPerlSock*, SOCKET, const char*, - int, int, const struct sockaddr*, int); + int, int, const struct sockaddr*, int); typedef void (*LPSethostent)(struct IPerlSock*, int); typedef void (*LPSetnetent)(struct IPerlSock*, int); typedef void (*LPSetprotoent)(struct IPerlSock*, int); typedef void (*LPSetservent)(struct IPerlSock*, int); typedef int (*LPSetsockopt)(struct IPerlSock*, SOCKET, int, int, - const char*, int); + const char*, int); typedef int (*LPShutdown)(struct IPerlSock*, SOCKET, int); typedef SOCKET (*LPSocket)(struct IPerlSock*, int, int, int); typedef int (*LPSocketpair)(struct IPerlSock*, int, int, int, - int*); + int*); #ifdef WIN32 typedef int (*LPClosesocket)(struct IPerlSock*, SOCKET s); #endif @@ -1286,95 +1286,95 @@ struct IPerlSockInfo }; #define PerlSock_htonl(x) \ - (*PL_Sock->pHtonl)(PL_Sock, x) + (*PL_Sock->pHtonl)(PL_Sock, x) #define PerlSock_htons(x) \ - (*PL_Sock->pHtons)(PL_Sock, x) + (*PL_Sock->pHtons)(PL_Sock, x) #define PerlSock_ntohl(x) \ - (*PL_Sock->pNtohl)(PL_Sock, x) + (*PL_Sock->pNtohl)(PL_Sock, x) #define PerlSock_ntohs(x) \ - (*PL_Sock->pNtohs)(PL_Sock, x) + (*PL_Sock->pNtohs)(PL_Sock, x) #define PerlSock_accept(s, a, l) \ - (*PL_Sock->pAccept)(PL_Sock, s, a, l) + (*PL_Sock->pAccept)(PL_Sock, s, a, l) #define PerlSock_bind(s, n, l) \ - (*PL_Sock->pBind)(PL_Sock, s, n, l) + (*PL_Sock->pBind)(PL_Sock, s, n, l) #define PerlSock_connect(s, n, l) \ - (*PL_Sock->pConnect)(PL_Sock, s, n, l) + (*PL_Sock->pConnect)(PL_Sock, s, n, l) #define PerlSock_endhostent() \ - (*PL_Sock->pEndhostent)(PL_Sock) + (*PL_Sock->pEndhostent)(PL_Sock) #define PerlSock_endnetent() \ - (*PL_Sock->pEndnetent)(PL_Sock) + (*PL_Sock->pEndnetent)(PL_Sock) #define PerlSock_endprotoent() \ - (*PL_Sock->pEndprotoent)(PL_Sock) + (*PL_Sock->pEndprotoent)(PL_Sock) #define PerlSock_endservent() \ - (*PL_Sock->pEndservent)(PL_Sock) + (*PL_Sock->pEndservent)(PL_Sock) #define PerlSock_gethostbyaddr(a, l, t) \ - (*PL_Sock->pGethostbyaddr)(PL_Sock, a, l, t) + (*PL_Sock->pGethostbyaddr)(PL_Sock, a, l, t) #define PerlSock_gethostbyname(n) \ - (*PL_Sock->pGethostbyname)(PL_Sock, n) + (*PL_Sock->pGethostbyname)(PL_Sock, n) #define PerlSock_gethostent() \ - (*PL_Sock->pGethostent)(PL_Sock) + (*PL_Sock->pGethostent)(PL_Sock) #define PerlSock_gethostname(n, l) \ - (*PL_Sock->pGethostname)(PL_Sock, n, l) + (*PL_Sock->pGethostname)(PL_Sock, n, l) #define PerlSock_getnetbyaddr(n, t) \ - (*PL_Sock->pGetnetbyaddr)(PL_Sock, n, t) + (*PL_Sock->pGetnetbyaddr)(PL_Sock, n, t) #define PerlSock_getnetbyname(c) \ - (*PL_Sock->pGetnetbyname)(PL_Sock, c) + (*PL_Sock->pGetnetbyname)(PL_Sock, c) #define PerlSock_getnetent() \ - (*PL_Sock->pGetnetent)(PL_Sock) + (*PL_Sock->pGetnetent)(PL_Sock) #define PerlSock_getpeername(s, n, l) \ - (*PL_Sock->pGetpeername)(PL_Sock, s, n, l) + (*PL_Sock->pGetpeername)(PL_Sock, s, n, l) #define PerlSock_getprotobyname(n) \ - (*PL_Sock->pGetprotobyname)(PL_Sock, n) + (*PL_Sock->pGetprotobyname)(PL_Sock, n) #define PerlSock_getprotobynumber(n) \ - (*PL_Sock->pGetprotobynumber)(PL_Sock, n) + (*PL_Sock->pGetprotobynumber)(PL_Sock, n) #define PerlSock_getprotoent() \ - (*PL_Sock->pGetprotoent)(PL_Sock) + (*PL_Sock->pGetprotoent)(PL_Sock) #define PerlSock_getservbyname(n, p) \ - (*PL_Sock->pGetservbyname)(PL_Sock, n, p) + (*PL_Sock->pGetservbyname)(PL_Sock, n, p) #define PerlSock_getservbyport(port, p) \ - (*PL_Sock->pGetservbyport)(PL_Sock, port, p) + (*PL_Sock->pGetservbyport)(PL_Sock, port, p) #define PerlSock_getservent() \ - (*PL_Sock->pGetservent)(PL_Sock) + (*PL_Sock->pGetservent)(PL_Sock) #define PerlSock_getsockname(s, n, l) \ - (*PL_Sock->pGetsockname)(PL_Sock, s, n, l) + (*PL_Sock->pGetsockname)(PL_Sock, s, n, l) #define PerlSock_getsockopt(s,l,n,v,i) \ - (*PL_Sock->pGetsockopt)(PL_Sock, s, l, n, v, i) + (*PL_Sock->pGetsockopt)(PL_Sock, s, l, n, v, i) #define PerlSock_inet_addr(c) \ - (*PL_Sock->pInetAddr)(PL_Sock, c) + (*PL_Sock->pInetAddr)(PL_Sock, c) #define PerlSock_inet_ntoa(i) \ - (*PL_Sock->pInetNtoa)(PL_Sock, i) + (*PL_Sock->pInetNtoa)(PL_Sock, i) #define PerlSock_listen(s, b) \ - (*PL_Sock->pListen)(PL_Sock, s, b) + (*PL_Sock->pListen)(PL_Sock, s, b) #define PerlSock_recv(s, b, l, f) \ - (*PL_Sock->pRecv)(PL_Sock, s, b, l, f) + (*PL_Sock->pRecv)(PL_Sock, s, b, l, f) #define PerlSock_recvfrom(s,b,l,f,from,fromlen) \ - (*PL_Sock->pRecvfrom)(PL_Sock, s, b, l, f, from, fromlen) + (*PL_Sock->pRecvfrom)(PL_Sock, s, b, l, f, from, fromlen) #define PerlSock_select(n, r, w, e, t) \ - (*PL_Sock->pSelect)(PL_Sock, n, (char*)r, (char*)w, (char*)e, t) + (*PL_Sock->pSelect)(PL_Sock, n, (char*)r, (char*)w, (char*)e, t) #define PerlSock_send(s, b, l, f) \ - (*PL_Sock->pSend)(PL_Sock, s, b, l, f) + (*PL_Sock->pSend)(PL_Sock, s, b, l, f) #define PerlSock_sendto(s, b, l, f, t, tlen) \ - (*PL_Sock->pSendto)(PL_Sock, s, b, l, f, t, tlen) + (*PL_Sock->pSendto)(PL_Sock, s, b, l, f, t, tlen) #define PerlSock_sethostent(f) \ - (*PL_Sock->pSethostent)(PL_Sock, f) + (*PL_Sock->pSethostent)(PL_Sock, f) #define PerlSock_setnetent(f) \ - (*PL_Sock->pSetnetent)(PL_Sock, f) + (*PL_Sock->pSetnetent)(PL_Sock, f) #define PerlSock_setprotoent(f) \ - (*PL_Sock->pSetprotoent)(PL_Sock, f) + (*PL_Sock->pSetprotoent)(PL_Sock, f) #define PerlSock_setservent(f) \ - (*PL_Sock->pSetservent)(PL_Sock, f) + (*PL_Sock->pSetservent)(PL_Sock, f) #define PerlSock_setsockopt(s, l, n, v, len) \ - (*PL_Sock->pSetsockopt)(PL_Sock, s, l, n, v, len) + (*PL_Sock->pSetsockopt)(PL_Sock, s, l, n, v, len) #define PerlSock_shutdown(s, h) \ - (*PL_Sock->pShutdown)(PL_Sock, s, h) + (*PL_Sock->pShutdown)(PL_Sock, s, h) #define PerlSock_socket(a, t, p) \ - (*PL_Sock->pSocket)(PL_Sock, a, t, p) + (*PL_Sock->pSocket)(PL_Sock, a, t, p) #define PerlSock_socketpair(a, t, p, f) \ - (*PL_Sock->pSocketpair)(PL_Sock, a, t, p, f) + (*PL_Sock->pSocketpair)(PL_Sock, a, t, p, f) #ifdef WIN32 #define PerlSock_closesocket(s) \ - (*PL_Sock->pClosesocket)(PL_Sock, s) + (*PL_Sock->pClosesocket)(PL_Sock, s) #endif #else /* PERL_IMPLICIT_SYS */ @@ -1416,17 +1416,17 @@ struct IPerlSockInfo #define PerlSock_listen(s, b) listen(s, b) #define PerlSock_recv(s, b, l, f) recv(s, b, l, f) #define PerlSock_recvfrom(s, b, l, f, from, fromlen) \ - recvfrom(s, b, l, f, from, fromlen) + recvfrom(s, b, l, f, from, fromlen) #define PerlSock_select(n, r, w, e, t) select(n, r, w, e, t) #define PerlSock_send(s, b, l, f) send(s, b, l, f) #define PerlSock_sendto(s, b, l, f, t, tlen) \ - sendto(s, b, l, f, t, tlen) + sendto(s, b, l, f, t, tlen) #define PerlSock_sethostent(f) sethostent(f) #define PerlSock_setnetent(f) setnetent(f) #define PerlSock_setprotoent(f) setprotoent(f) #define PerlSock_setservent(f) setservent(f) #define PerlSock_setsockopt(s, l, n, v, len) \ - setsockopt(s, l, n, v, len) + setsockopt(s, l, n, v, len) #define PerlSock_shutdown(s, h) shutdown(s, h) #define PerlSock_socket(a, t, p) socket(a, t, p) #define PerlSock_socketpair(a, t, p, f) socketpair(a, t, p, f) @@ -142,21 +142,21 @@ S_stdize_locale(pTHX_ char *locs) PERL_ARGS_ASSERT_STDIZE_LOCALE; if (s) { - const char * const t = strchr(s, '.'); - okay = FALSE; - if (t) { - const char * const u = strchr(t, '\n'); - if (u && (u[1] == 0)) { - const STRLEN len = u - s; - Move(s + 1, locs, len, char); - locs[len] = 0; - okay = TRUE; - } - } + const char * const t = strchr(s, '.'); + okay = FALSE; + if (t) { + const char * const u = strchr(t, '\n'); + if (u && (u[1] == 0)) { + const STRLEN len = u - s; + Move(s + 1, locs, len, char); + locs[len] = 0; + okay = TRUE; + } + } } if (!okay) - Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs); + Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs); return locs; } @@ -1440,12 +1440,12 @@ S_new_numeric(pTHX_ const char *newnum) char *save_newnum; if (! newnum) { - Safefree(PL_numeric_name); - PL_numeric_name = NULL; - PL_numeric_standard = TRUE; - PL_numeric_underlying = TRUE; - PL_numeric_underlying_is_standard = TRUE; - return; + Safefree(PL_numeric_name); + PL_numeric_name = NULL; + PL_numeric_standard = TRUE; + PL_numeric_underlying = TRUE; + PL_numeric_underlying_is_standard = TRUE; + return; } save_newnum = stdize_locale(savepv(newnum)); @@ -1468,11 +1468,11 @@ S_new_numeric(pTHX_ const char *newnum) /* Save the new name if it isn't the same as the previous one, if any */ if (! PL_numeric_name || strNE(PL_numeric_name, save_newnum)) { - Safefree(PL_numeric_name); - PL_numeric_name = save_newnum; + Safefree(PL_numeric_name); + PL_numeric_name = save_newnum; } else { - Safefree(save_newnum); + Safefree(save_newnum); } PL_numeric_underlying_is_standard = PL_numeric_standard; @@ -1925,27 +1925,27 @@ S_new_collate(pTHX_ const char *newcoll) * an unlikely bug */ if (! newcoll) { - if (PL_collation_name) { - ++PL_collation_ix; - Safefree(PL_collation_name); - PL_collation_name = NULL; - } - PL_collation_standard = TRUE; + if (PL_collation_name) { + ++PL_collation_ix; + Safefree(PL_collation_name); + PL_collation_name = NULL; + } + PL_collation_standard = TRUE; is_standard_collation: - PL_collxfrm_base = 0; - PL_collxfrm_mult = 2; + PL_collxfrm_base = 0; + PL_collxfrm_mult = 2; PL_in_utf8_COLLATE_locale = FALSE; PL_strxfrm_NUL_replacement = '\0'; PL_strxfrm_max_cp = 0; - return; + return; } /* If this is not the same locale as currently, set the new one up */ if (! PL_collation_name || strNE(PL_collation_name, newcoll)) { - ++PL_collation_ix; - Safefree(PL_collation_name); - PL_collation_name = stdize_locale(savepv(newcoll)); - PL_collation_standard = isNAME_C_OR_POSIX(newcoll); + ++PL_collation_ix; + Safefree(PL_collation_name); + PL_collation_name = stdize_locale(savepv(newcoll)); + PL_collation_standard = isNAME_C_OR_POSIX(newcoll); if (PL_collation_standard) { goto is_standard_collation; } @@ -1995,7 +1995,7 @@ S_new_collate(pTHX_ const char *newcoll) * get it right the first time to avoid wasted expensive string * transformations. */ - { + { /* We use the string below to find how long the tranformation of it * is. Almost all locales are supersets of ASCII, or at least the * ASCII letters. We use all of them, half upper half lower, @@ -2111,7 +2111,7 @@ S_new_collate(pTHX_ const char *newcoll) } # endif - } + } } #endif /* USE_LOCALE_COLLATE */ @@ -3367,8 +3367,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) DEBUG_INITIALIZATION_set(cBOOL(PerlEnv_getenv("PERL_DEBUG_LOCALE_INIT"))); # define DEBUG_LOCALE_INIT(category, locale, result) \ - STMT_START { \ - if (debug_initialization) { \ + STMT_START { \ + if (debug_initialization) { \ PerlIO_printf(Perl_debug_log, \ "%s:%d: %s\n", \ __FILE__, __LINE__, \ @@ -3376,7 +3376,7 @@ Perl_init_i18nl10n(pTHX_ int printwarn) locale, \ result)); \ } \ - } STMT_END + } STMT_END /* Make sure the parallel arrays are properly set up */ # ifdef USE_LOCALE_NUMERIC @@ -3921,10 +3921,10 @@ Perl_init_i18nl10n(pTHX_ int printwarn) This is an alternative to using the -C command line switch (the -C if present will override this). */ { - const char *p = PerlEnv_getenv("PERL_UNICODE"); - PL_unicode = p ? parse_unicode_opts(&p) : 0; - if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) - PL_utf8cache = -1; + const char *p = PerlEnv_getenv("PERL_UNICODE"); + PL_unicode = p ? parse_unicode_opts(&p) : 0; + if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) + PL_utf8cache = -1; } # endif @@ -4287,7 +4287,7 @@ Perl__mem_collxfrm(pTHX_ const char *input_string, if (UNLIKELY(! xbuf)) { DEBUG_L(PerlIO_printf(Perl_debug_log, "_mem_collxfrm: Couldn't malloc %zu bytes\n", xAlloc)); - goto bad; + goto bad; } /* Store the collation id */ @@ -149,13 +149,13 @@ # Do not allow configuration of runtime options via $ENV{PERL_MALLOC_OPT} NO_PERL_MALLOC_ENV undef - [The variable consists of ;-separated parts of the form CODE=VALUE - with 1-character codes F, M, f, A, P, G, d, a, c for runtime - configuration of FIRST_SBRK, MIN_SBRK, MIN_SBRK_FRAC1000, - SBRK_ALLOW_FAILURES, SBRK_FAILURE_PRICE, sbrk_goodness, - filldead, fillalive, fillcheck. The last 3 are for DEBUGGING - build, and allow switching the tests for free()ed memory read, - uninit memory reads, and free()ed memory write.] + [The variable consists of ;-separated parts of the form CODE=VALUE + with 1-character codes F, M, f, A, P, G, d, a, c for runtime + configuration of FIRST_SBRK, MIN_SBRK, MIN_SBRK_FRAC1000, + SBRK_ALLOW_FAILURES, SBRK_FAILURE_PRICE, sbrk_goodness, + filldead, fillalive, fillcheck. The last 3 are for DEBUGGING + build, and allow switching the tests for free()ed memory read, + uninit memory reads, and free()ed memory write.] This implementation assumes that calling PerlIO_printf() does not result in any memory allocation calls (used during a panic). @@ -281,14 +281,14 @@ # undef DEBUG_m # define DEBUG_m(a) \ STMT_START { \ - if (PERL_MAYBE_ALIVE && PERL_GET_THX) { \ - dTHX; \ - if (DEBUG_m_TEST) { \ - PL_debug &= ~DEBUG_m_FLAG; \ - a; \ - PL_debug |= DEBUG_m_FLAG; \ - } \ - } \ + if (PERL_MAYBE_ALIVE && PERL_GET_THX) { \ + dTHX; \ + if (DEBUG_m_TEST) { \ + PL_debug &= ~DEBUG_m_FLAG; \ + a; \ + PL_debug |= DEBUG_m_FLAG; \ + } \ + } \ } STMT_END #endif @@ -389,27 +389,27 @@ * plus the range checking words, and the header word MINUS ONE. */ union overhead { - union overhead *ov_next; /* when free */ + union overhead *ov_next; /* when free */ #if MEM_ALIGNBYTES > 4 - double strut; /* alignment problems */ + double strut; /* alignment problems */ # if MEM_ALIGNBYTES > 8 - char sstrut[MEM_ALIGNBYTES]; /* for the sizing */ + char sstrut[MEM_ALIGNBYTES]; /* for the sizing */ # endif #endif - struct { + struct { /* * Keep the ovu_index and ovu_magic in this order, having a char * field first gives alignment indigestion in some systems, such as * MachTen. */ - u_char ovu_index; /* bucket # */ - u_char ovu_magic; /* magic number */ + u_char ovu_index; /* bucket # */ + u_char ovu_magic; /* magic number */ #ifdef RCHECK - /* Subtract one to fit into u_short for an extra bucket */ - u_short ovu_size; /* block size (requested + overhead - 1) */ - u_int ovu_rmagic; /* range magic number */ + /* Subtract one to fit into u_short for an extra bucket */ + u_short ovu_size; /* block size (requested + overhead - 1) */ + u_int ovu_rmagic; /* range magic number */ #endif - } ovu; + } ovu; #define ov_magic ovu.ovu_magic #define ov_index ovu.ovu_index #define ov_size ovu.ovu_size @@ -466,10 +466,10 @@ static const u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = }; # define BUCKET_SIZE_NO_SURPLUS(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT))) # define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE \ - ? ((size_t)buck_size[i]) \ - : ((((size_t)1) << ((i) >> BUCKET_POW2_SHIFT)) \ - - MEM_OVERHEAD(i) \ - + POW2_OPTIMIZE_SURPLUS(i))) + ? ((size_t)buck_size[i]) \ + : ((((size_t)1) << ((i) >> BUCKET_POW2_SHIFT)) \ + - MEM_OVERHEAD(i) \ + + POW2_OPTIMIZE_SURPLUS(i))) #else # define BUCKET_SIZE_NO_SURPLUS(i) (((size_t)1) << ((i) >> BUCKET_POW2_SHIFT)) # define BUCKET_SIZE(i) (BUCKET_SIZE_NO_SURPLUS(i) + POW2_OPTIMIZE_SURPLUS(i)) @@ -602,9 +602,9 @@ static const u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = # define OV_INDEXp(block) (INT2PTR(u_char*,TWOK_MASKED(block))) # define OV_INDEX(block) (*OV_INDEXp(block)) # define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) + \ - (TWOK_SHIFT(block)>> \ - (bucket>>BUCKET_POW2_SHIFT)) + \ - (bucket >= MIN_NEEDS_SHIFT ? 1 : 0))) + (TWOK_SHIFT(block)>> \ + (bucket>>BUCKET_POW2_SHIFT)) + \ + (bucket >= MIN_NEEDS_SHIFT ? 1 : 0))) /* A bucket can have a shift smaller than it size, we need to shift its magic number so it will not overwrite index: */ # ifdef BUCKETS_ROOT2 @@ -618,8 +618,8 @@ static const u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = #ifdef IGNORE_SMALL_BAD_FREE #define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */ # define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \ - ? nBIT_MASK(LOG_OF_MIN_ARENA)/BUCKET_SIZE_NO_SURPLUS(bucket) \ - : n_blks[bucket] ) + ? nBIT_MASK(LOG_OF_MIN_ARENA)/BUCKET_SIZE_NO_SURPLUS(bucket) \ + : n_blks[bucket] ) #else # define N_BLKS(bucket) n_blks[bucket] #endif @@ -640,9 +640,9 @@ static const u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = /* Shift of the first bucket with the given ordinal inside 2K chunk. */ #ifdef IGNORE_SMALL_BAD_FREE # define BLK_SHIFT(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \ - ? ((1<<LOG_OF_MIN_ARENA) \ - - BUCKET_SIZE_NO_SURPLUS(bucket) * N_BLKS(bucket)) \ - : blk_shift[bucket]) + ? ((1<<LOG_OF_MIN_ARENA) \ + - BUCKET_SIZE_NO_SURPLUS(bucket) * N_BLKS(bucket)) \ + : blk_shift[bucket]) #else # define BLK_SHIFT(bucket) blk_shift[bucket] #endif @@ -927,8 +927,8 @@ static u_int goodsbrk; # ifdef NO_MALLOC_DYNAMIC_CFG static MEM_SIZE emergency_buffer_size; - /* 0 if the last request for more memory succeeded. - Otherwise the size of the failing request. */ + /* 0 if the last request for more memory succeeded. + Otherwise the size of the failing request. */ static MEM_SIZE emergency_buffer_last_req; static char *emergency_buffer; static char *emergency_buffer_prepared; @@ -992,54 +992,54 @@ emergency_sbrk(MEM_SIZE size) MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA; if (size >= BIG_SIZE - && (!emergency_buffer_last_req || - (size < (MEM_SIZE)emergency_buffer_last_req))) { - /* Give the possibility to recover, but avoid an infinite cycle. */ - MALLOC_UNLOCK; - emergency_buffer_last_req = size; - emergency_sbrk_croak("Out of memory during \"large\" request for %" UVuf + && (!emergency_buffer_last_req || + (size < (MEM_SIZE)emergency_buffer_last_req))) { + /* Give the possibility to recover, but avoid an infinite cycle. */ + MALLOC_UNLOCK; + emergency_buffer_last_req = size; + emergency_sbrk_croak("Out of memory during \"large\" request for %" UVuf " bytes, total sbrk() is %" UVuf " bytes", (UV)size, (UV)(goodsbrk + sbrk_slack)); } if ((MEM_SIZE)emergency_buffer_size >= rsize) { - char *old = emergency_buffer; - - emergency_buffer_size -= rsize; - emergency_buffer += rsize; - return old; + char *old = emergency_buffer; + + emergency_buffer_size -= rsize; + emergency_buffer += rsize; + return old; } else { - /* First offense, give a possibility to recover by dieing. */ - /* No malloc involved here: */ - IV Size; - char *pv = GET_EMERGENCY_BUFFER(&Size); - int have = 0; - - if (emergency_buffer_size) { - add_to_chain(emergency_buffer, emergency_buffer_size, 0); - emergency_buffer_size = 0; - emergency_buffer = NULL; - have = 1; - } - - if (!pv) - pv = PERL_GET_EMERGENCY_BUFFER(&Size); - if (!pv) { - if (have) - goto do_croak; - return (char *)-1; /* Now die die die... */ - } - - /* Check alignment: */ - if (PTR2UV(pv) & (NEEDED_ALIGNMENT - 1)) { - dTHX; - - PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n"); - return (char *)-1; /* die die die */ - } - - emergency_buffer = pv; - emergency_buffer_size = Size; + /* First offense, give a possibility to recover by dieing. */ + /* No malloc involved here: */ + IV Size; + char *pv = GET_EMERGENCY_BUFFER(&Size); + int have = 0; + + if (emergency_buffer_size) { + add_to_chain(emergency_buffer, emergency_buffer_size, 0); + emergency_buffer_size = 0; + emergency_buffer = NULL; + have = 1; + } + + if (!pv) + pv = PERL_GET_EMERGENCY_BUFFER(&Size); + if (!pv) { + if (have) + goto do_croak; + return (char *)-1; /* Now die die die... */ + } + + /* Check alignment: */ + if (PTR2UV(pv) & (NEEDED_ALIGNMENT - 1)) { + dTHX; + + PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n"); + return (char *)-1; /* die die die */ + } + + emergency_buffer = pv; + emergency_buffer_size = Size; } do_croak: MALLOC_UNLOCK; @@ -1066,32 +1066,32 @@ botch(const char *diag, const char *s, const char *file, int line) { dTHX; if (!(PERL_MAYBE_ALIVE && PERL_GET_THX)) - goto do_write; + goto do_write; else { - if (PerlIO_printf(PerlIO_stderr(), - "assertion botched (%s?): %s %s:%d\n", - diag, s, file, line) != 0) { - do_write: /* Can be initializing interpreter */ - MYMALLOC_WRITE2STDERR("assertion botched ("); - MYMALLOC_WRITE2STDERR(diag); - MYMALLOC_WRITE2STDERR("?): "); - MYMALLOC_WRITE2STDERR(s); - MYMALLOC_WRITE2STDERR(" ("); - MYMALLOC_WRITE2STDERR(file); - MYMALLOC_WRITE2STDERR(":"); - { - char linebuf[10]; - char *s = linebuf + sizeof(linebuf) - 1; - int n = line; - *s = 0; - do { - *--s = '0' + (n % 10); - } while (n /= 10); - MYMALLOC_WRITE2STDERR(s); - } - MYMALLOC_WRITE2STDERR(")\n"); - } - PerlProc_abort(); + if (PerlIO_printf(PerlIO_stderr(), + "assertion botched (%s?): %s %s:%d\n", + diag, s, file, line) != 0) { + do_write: /* Can be initializing interpreter */ + MYMALLOC_WRITE2STDERR("assertion botched ("); + MYMALLOC_WRITE2STDERR(diag); + MYMALLOC_WRITE2STDERR("?): "); + MYMALLOC_WRITE2STDERR(s); + MYMALLOC_WRITE2STDERR(" ("); + MYMALLOC_WRITE2STDERR(file); + MYMALLOC_WRITE2STDERR(":"); + { + char linebuf[10]; + char *s = linebuf + sizeof(linebuf) - 1; + int n = line; + *s = 0; + do { + *--s = '0' + (n % 10); + } while (n /= 10); + MYMALLOC_WRITE2STDERR(s); + } + MYMALLOC_WRITE2STDERR(")\n"); + } + PerlProc_abort(); } } #else @@ -1108,19 +1108,19 @@ fill_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) const long lfill = *(long*)fill; if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */ - int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); - unsigned const char *f = fill + sizeof(long) - shift; - unsigned char *e1 = s + shift; + int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); + unsigned const char *f = fill + sizeof(long) - shift; + unsigned char *e1 = s + shift; - while (s < e1) - *s++ = *f++; + while (s < e1) + *s++ = *f++; } lp = (long*)s; while ((unsigned char*)(lp + 1) <= e) - *lp++ = lfill; + *lp++ = lfill; s = (unsigned char*)lp; while (s < e) - *s++ = *fill++; + *s++ = *fill++; } /* Just malloc()ed */ static const unsigned char fill_feedadad[] = @@ -1131,9 +1131,9 @@ static const unsigned char fill_deadbeef[] = {0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF}; # define FILL_DEADBEEF(s, n) \ - (void)(FILL_DEAD? (fill_pat_4bytes((s), (n), fill_deadbeef), 0) : 0) + (void)(FILL_DEAD? (fill_pat_4bytes((s), (n), fill_deadbeef), 0) : 0) # define FILL_FEEDADAD(s, n) \ - (void)(FILL_ALIVE? (fill_pat_4bytes((s), (n), fill_feedadad), 0) : 0) + (void)(FILL_ALIVE? (fill_pat_4bytes((s), (n), fill_feedadad), 0) : 0) #else # define FILL_DEADBEEF(s, n) ((void)0) # define FILL_FEEDADAD(s, n) ((void)0) @@ -1149,27 +1149,27 @@ cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) const long lfill = *(long*)fill; if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */ - int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); - unsigned const char *f = fill + sizeof(long) - shift; - unsigned char *e1 = s + shift; + int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1)); + unsigned const char *f = fill + sizeof(long) - shift; + unsigned char *e1 = s + shift; - while (s < e1) - if (*s++ != *f++) - return 1; + while (s < e1) + if (*s++ != *f++) + return 1; } lp = (long*)s; while ((unsigned char*)(lp + 1) <= e) - if (*lp++ != lfill) - return 1; + if (*lp++ != lfill) + return 1; s = (unsigned char*)lp; while (s < e) - if (*s++ != *fill++) - return 1; + if (*s++ != *fill++) + return 1; return 0; } # define FILLCHECK_DEADBEEF(s, n) \ - ASSERT(!FILL_CHECK || !cmp_pat_4bytes(s, n, fill_deadbeef), \ - "free()ed/realloc()ed-away memory was overwritten") + ASSERT(!FILL_CHECK || !cmp_pat_4bytes(s, n, fill_deadbeef), \ + "free()ed/realloc()ed-away memory was overwritten") #else # define FILLCHECK_DEADBEEF(s, n) ((void)0) #endif @@ -1177,49 +1177,49 @@ cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill) STATIC int S_adjust_size_and_find_bucket(size_t *nbytes_p) { - MEM_SIZE shiftr; - int bucket; - size_t nbytes; + MEM_SIZE shiftr; + int bucket; + size_t nbytes; - PERL_ARGS_ASSERT_ADJUST_SIZE_AND_FIND_BUCKET; + PERL_ARGS_ASSERT_ADJUST_SIZE_AND_FIND_BUCKET; - nbytes = *nbytes_p; + nbytes = *nbytes_p; - /* - * Convert amount of memory requested into - * closest block size stored in hash buckets - * which satisfies request. Account for - * space used per block for accounting. - */ + /* + * Convert amount of memory requested into + * closest block size stored in hash buckets + * which satisfies request. Account for + * space used per block for accounting. + */ #ifdef PACK_MALLOC # ifdef SMALL_BUCKET_VIA_TABLE - if (nbytes == 0) - bucket = MIN_BUCKET; - else if (nbytes <= SIZE_TABLE_MAX) { - bucket = bucket_of[(nbytes - 1) >> BUCKET_TABLE_SHIFT]; - } else + if (nbytes == 0) + bucket = MIN_BUCKET; + else if (nbytes <= SIZE_TABLE_MAX) { + bucket = bucket_of[(nbytes - 1) >> BUCKET_TABLE_SHIFT]; + } else # else - if (nbytes == 0) - nbytes = 1; - if (nbytes <= MAX_POW2_ALGO) goto do_shifts; - else + if (nbytes == 0) + nbytes = 1; + if (nbytes <= MAX_POW2_ALGO) goto do_shifts; + else # endif #endif - { - POW2_OPTIMIZE_ADJUST(nbytes); - nbytes += M_OVERHEAD; - nbytes = (nbytes + 3) &~ 3; + { + POW2_OPTIMIZE_ADJUST(nbytes); + nbytes += M_OVERHEAD; + nbytes = (nbytes + 3) &~ 3; #if defined(PACK_MALLOC) && !defined(SMALL_BUCKET_VIA_TABLE) - do_shifts: + do_shifts: #endif - shiftr = (nbytes - 1) >> START_SHIFT; - bucket = START_SHIFTS_BUCKET; - /* apart from this loop, this is O(1) */ - while (shiftr >>= 1) - bucket += BUCKETS_PER_POW2; - } - *nbytes_p = nbytes; - return bucket; + shiftr = (nbytes - 1) >> START_SHIFT; + bucket = START_SHIFTS_BUCKET; + /* apart from this loop, this is O(1) */ + while (shiftr >>= 1) + bucket += BUCKETS_PER_POW2; + } + *nbytes_p = nbytes; + return bucket; } /* @@ -1234,10 +1234,10 @@ These have the same interfaces as the C lib ones, so are considered documented Malloc_t Perl_malloc(size_t nbytes) { - union overhead *p; - int bucket; + union overhead *p; + int bucket; #if defined(DEBUGGING) || defined(RCHECK) - MEM_SIZE size = nbytes; + MEM_SIZE size = nbytes; #endif /* A structure that has more than PTRDIFF_MAX bytes is unfortunately @@ -1253,119 +1253,119 @@ Perl_malloc(size_t nbytes) return NULL; } - BARK_64K_LIMIT("Allocation",nbytes,nbytes); + BARK_64K_LIMIT("Allocation",nbytes,nbytes); #ifdef DEBUGGING - if ((long)nbytes < 0) - croak("%s", "panic: malloc"); + if ((long)nbytes < 0) + croak("%s", "panic: malloc"); #endif - bucket = adjust_size_and_find_bucket(&nbytes); - MALLOC_LOCK; - /* - * If nothing in hash bucket right now, - * request more memory from the system. - */ - if (nextf[bucket] == NULL) - morecore(bucket); - if ((p = nextf[bucket]) == NULL) { - MALLOC_UNLOCK; - { - dTHX; - if (!PL_nomemok) { + bucket = adjust_size_and_find_bucket(&nbytes); + MALLOC_LOCK; + /* + * If nothing in hash bucket right now, + * request more memory from the system. + */ + if (nextf[bucket] == NULL) + morecore(bucket); + if ((p = nextf[bucket]) == NULL) { + MALLOC_UNLOCK; + { + dTHX; + if (!PL_nomemok) { #if defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) - MYMALLOC_WRITE2STDERR("Out of memory!\n"); + MYMALLOC_WRITE2STDERR("Out of memory!\n"); #else - char buff[80]; - char *eb = buff + sizeof(buff) - 1; - char *s = eb; - size_t n = nbytes; + char buff[80]; + char *eb = buff + sizeof(buff) - 1; + char *s = eb; + size_t n = nbytes; - MYMALLOC_WRITE2STDERR("Out of memory during request for "); + MYMALLOC_WRITE2STDERR("Out of memory during request for "); #if defined(DEBUGGING) || defined(RCHECK) - n = size; + n = size; #endif - *s = 0; - do { - *--s = '0' + (n % 10); - } while (n /= 10); - MYMALLOC_WRITE2STDERR(s); - MYMALLOC_WRITE2STDERR(" bytes, total sbrk() is "); - s = eb; - n = goodsbrk + sbrk_slack; - do { - *--s = '0' + (n % 10); - } while (n /= 10); - MYMALLOC_WRITE2STDERR(s); - MYMALLOC_WRITE2STDERR(" bytes!\n"); + *s = 0; + do { + *--s = '0' + (n % 10); + } while (n /= 10); + MYMALLOC_WRITE2STDERR(s); + MYMALLOC_WRITE2STDERR(" bytes, total sbrk() is "); + s = eb; + n = goodsbrk + sbrk_slack; + do { + *--s = '0' + (n % 10); + } while (n /= 10); + MYMALLOC_WRITE2STDERR(s); + MYMALLOC_WRITE2STDERR(" bytes!\n"); #endif /* defined(PLAIN_MALLOC) && defined(NO_FANCY_MALLOC) */ - my_exit(1); - } - } - return (NULL); - } + my_exit(1); + } + } + return (NULL); + } - /* remove from linked list */ + /* remove from linked list */ #ifdef DEBUGGING - if ( (PTR2UV(p) & (MEM_ALIGNBYTES - 1)) - /* Can't get this low */ - || (p && PTR2UV(p) < (1<<LOG_OF_MIN_ARENA)) ) { - dTHX; - PerlIO_printf(PerlIO_stderr(), - "Unaligned pointer in the free chain 0x%" UVxf "\n", - PTR2UV(p)); - } - if ( (PTR2UV(p->ov_next) & (MEM_ALIGNBYTES - 1)) - || (p->ov_next && PTR2UV(p->ov_next) < (1<<LOG_OF_MIN_ARENA)) ) { - dTHX; - PerlIO_printf(PerlIO_stderr(), - "Unaligned \"next\" pointer in the free " - "chain 0x%" UVxf " at 0x%" UVxf "\n", - PTR2UV(p->ov_next), PTR2UV(p)); - } + if ( (PTR2UV(p) & (MEM_ALIGNBYTES - 1)) + /* Can't get this low */ + || (p && PTR2UV(p) < (1<<LOG_OF_MIN_ARENA)) ) { + dTHX; + PerlIO_printf(PerlIO_stderr(), + "Unaligned pointer in the free chain 0x%" UVxf "\n", + PTR2UV(p)); + } + if ( (PTR2UV(p->ov_next) & (MEM_ALIGNBYTES - 1)) + || (p->ov_next && PTR2UV(p->ov_next) < (1<<LOG_OF_MIN_ARENA)) ) { + dTHX; + PerlIO_printf(PerlIO_stderr(), + "Unaligned \"next\" pointer in the free " + "chain 0x%" UVxf " at 0x%" UVxf "\n", + PTR2UV(p->ov_next), PTR2UV(p)); + } #endif - nextf[bucket] = p->ov_next; + nextf[bucket] = p->ov_next; - MALLOC_UNLOCK; + MALLOC_UNLOCK; - DEBUG_m(PerlIO_printf(Perl_debug_log, - "%p: (%05lu) malloc %ld bytes\n", - (Malloc_t)(p + CHUNK_SHIFT), + DEBUG_m(PerlIO_printf(Perl_debug_log, + "%p: (%05lu) malloc %ld bytes\n", + (Malloc_t)(p + CHUNK_SHIFT), (unsigned long)(PL_an++), - (long)size)); + (long)size)); - FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT), - BUCKET_SIZE_REAL(bucket) + RMAGIC_SZ); + FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT), + BUCKET_SIZE_REAL(bucket) + RMAGIC_SZ); #ifdef IGNORE_SMALL_BAD_FREE - if (bucket >= FIRST_BUCKET_WITH_CHECK) + if (bucket >= FIRST_BUCKET_WITH_CHECK) #endif - OV_MAGIC(p, bucket) = MAGIC; + OV_MAGIC(p, bucket) = MAGIC; #ifndef PACK_MALLOC - OV_INDEX(p) = bucket; + OV_INDEX(p) = bucket; #endif #ifdef RCHECK - /* - * Record allocated size of block and - * bound space with magic numbers. - */ - p->ov_rmagic = RMAGIC; - if (bucket <= MAX_SHORT_BUCKET) { - int i; - - nbytes = size + M_OVERHEAD; - p->ov_size = nbytes - 1; - if ((i = nbytes & (RMAGIC_SZ-1))) { - i = RMAGIC_SZ - i; - while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */ - ((caddr_t)p + nbytes - RMAGIC_SZ)[i] = RMAGIC_C; - } - /* Same at RMAGIC_SZ-aligned RMAGIC */ - nbytes = (nbytes + RMAGIC_SZ - 1) & ~(RMAGIC_SZ - 1); - ((u_int *)((caddr_t)p + nbytes))[-1] = RMAGIC; - } - FILL_FEEDADAD((unsigned char *)(p + CHUNK_SHIFT), size); + /* + * Record allocated size of block and + * bound space with magic numbers. + */ + p->ov_rmagic = RMAGIC; + if (bucket <= MAX_SHORT_BUCKET) { + int i; + + nbytes = size + M_OVERHEAD; + p->ov_size = nbytes - 1; + if ((i = nbytes & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */ + ((caddr_t)p + nbytes - RMAGIC_SZ)[i] = RMAGIC_C; + } + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nbytes = (nbytes + RMAGIC_SZ - 1) & ~(RMAGIC_SZ - 1); + ((u_int *)((caddr_t)p + nbytes))[-1] = RMAGIC; + } + FILL_FEEDADAD((unsigned char *)(p + CHUNK_SHIFT), size); #endif - return ((Malloc_t)(p + CHUNK_SHIFT)); + return ((Malloc_t)(p + CHUNK_SHIFT)); } static char *last_sbrk_top; @@ -1393,33 +1393,33 @@ get_from_chain(MEM_SIZE size) long min_remain = LONG_MAX; while (elt) { - if (elt->size >= size) { - long remains = elt->size - size; - if (remains >= 0 && remains < min_remain) { - oldgoodp = oldp; - min_remain = remains; - } - if (remains == 0) { - break; - } - } - oldp = &( elt->next ); - elt = elt->next; + if (elt->size >= size) { + long remains = elt->size - size; + if (remains >= 0 && remains < min_remain) { + oldgoodp = oldp; + min_remain = remains; + } + if (remains == 0) { + break; + } + } + oldp = &( elt->next ); + elt = elt->next; } if (!oldgoodp) return NULL; if (min_remain) { - void *ret = *oldgoodp; - struct chunk_chain_s *next = (*oldgoodp)->next; - - *oldgoodp = (struct chunk_chain_s *)((char*)ret + size); - (*oldgoodp)->size = min_remain; - (*oldgoodp)->next = next; - return ret; + void *ret = *oldgoodp; + struct chunk_chain_s *next = (*oldgoodp)->next; + + *oldgoodp = (struct chunk_chain_s *)((char*)ret + size); + (*oldgoodp)->size = min_remain; + (*oldgoodp)->next = next; + return ret; } else { - void *ret = *oldgoodp; - *oldgoodp = (*oldgoodp)->next; - n_chunks--; - return ret; + void *ret = *oldgoodp; + *oldgoodp = (*oldgoodp)->next; + n_chunks--; + return ret; } } @@ -1442,26 +1442,26 @@ get_from_bigger_buckets(int bucket, MEM_SIZE size) int price = 1; static int bucketprice[NBUCKETS]; while (bucket <= max_bucket) { - /* We postpone stealing from bigger buckets until we want it - often enough. */ - if (nextf[bucket] && bucketprice[bucket]++ >= price) { - /* Steal it! */ - void *ret = (void*)(nextf[bucket] - 1 + CHUNK_SHIFT); - bucketprice[bucket] = 0; - if (((char*)nextf[bucket]) - M_OVERHEAD == last_op) { - last_op = NULL; /* Disable optimization */ - } - nextf[bucket] = nextf[bucket]->ov_next; + /* We postpone stealing from bigger buckets until we want it + often enough. */ + if (nextf[bucket] && bucketprice[bucket]++ >= price) { + /* Steal it! */ + void *ret = (void*)(nextf[bucket] - 1 + CHUNK_SHIFT); + bucketprice[bucket] = 0; + if (((char*)nextf[bucket]) - M_OVERHEAD == last_op) { + last_op = NULL; /* Disable optimization */ + } + nextf[bucket] = nextf[bucket]->ov_next; #ifdef DEBUGGING_MSTATS - nmalloc[bucket]--; - start_slack -= M_OVERHEAD; + nmalloc[bucket]--; + start_slack -= M_OVERHEAD; #endif - add_to_chain(ret, (BUCKET_SIZE_NO_SURPLUS(bucket) + - POW2_OPTIMIZE_SURPLUS(bucket)), - size); - return ret; - } - bucket++; + add_to_chain(ret, (BUCKET_SIZE_NO_SURPLUS(bucket) + + POW2_OPTIMIZE_SURPLUS(bucket)), + size); + return ret; + } + bucket++; } return NULL; } @@ -1477,134 +1477,134 @@ getpages(MEM_SIZE needed, int *nblksp, int bucket) MEM_SIZE slack = 0; if (sbrk_goodness > 0) { - if (!last_sbrk_top && require < (MEM_SIZE)FIRST_SBRK) - require = FIRST_SBRK; - else if (require < (MEM_SIZE)MIN_SBRK) require = MIN_SBRK; + if (!last_sbrk_top && require < (MEM_SIZE)FIRST_SBRK) + require = FIRST_SBRK; + else if (require < (MEM_SIZE)MIN_SBRK) require = MIN_SBRK; - if (require < (Size_t)(goodsbrk * MIN_SBRK_FRAC1000 / 1000)) - require = goodsbrk * MIN_SBRK_FRAC1000 / 1000; - require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK; + if (require < (Size_t)(goodsbrk * MIN_SBRK_FRAC1000 / 1000)) + require = goodsbrk * MIN_SBRK_FRAC1000 / 1000; + require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK; } else { - require = needed; - last_sbrk_top = 0; - sbrked_remains = 0; + require = needed; + last_sbrk_top = 0; + sbrked_remains = 0; } DEBUG_m(PerlIO_printf(Perl_debug_log, - "sbrk(%ld) for %ld-byte-long arena\n", - (long)require, (long) needed)); + "sbrk(%ld) for %ld-byte-long arena\n", + (long)require, (long) needed)); cp = (char *)sbrk(require); #ifdef DEBUGGING_MSTATS sbrks++; #endif if (cp == last_sbrk_top) { - /* Common case, anything is fine. */ - sbrk_goodness++; - ovp = (union overhead *) (cp - sbrked_remains); - last_op = cp - sbrked_remains; - sbrked_remains = require - (needed - sbrked_remains); + /* Common case, anything is fine. */ + sbrk_goodness++; + ovp = (union overhead *) (cp - sbrked_remains); + last_op = cp - sbrked_remains; + sbrked_remains = require - (needed - sbrked_remains); } else if (cp == (char *)-1) { /* no more room! */ - ovp = (union overhead *)emergency_sbrk(needed); - if (ovp == (union overhead *)-1) - return 0; - if (((char*)ovp) > last_op) { /* Cannot happen with current emergency_sbrk() */ - last_op = 0; - } - return ovp; + ovp = (union overhead *)emergency_sbrk(needed); + if (ovp == (union overhead *)-1) + return 0; + if (((char*)ovp) > last_op) { /* Cannot happen with current emergency_sbrk() */ + last_op = 0; + } + return ovp; } else { /* Non-continuous or first sbrk(). */ - long add = sbrked_remains; - char *newcp; - - if (sbrked_remains) { /* Put rest into chain, we - cannot use it right now. */ - add_to_chain((void*)(last_sbrk_top - sbrked_remains), - sbrked_remains, 0); - } - - /* Second, check alignment. */ - slack = 0; - - /* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may - improve performance of memory access. */ - if (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */ - slack = WANTED_ALIGNMENT - (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)); - add += slack; - } - - if (add) { - DEBUG_m(PerlIO_printf(Perl_debug_log, - "sbrk(%ld) to fix non-continuous/off-page sbrk:\n\t%ld for alignment,\t%ld were assumed to come from the tail of the previous sbrk\n", - (long)add, (long) slack, - (long) sbrked_remains)); - newcp = (char *)sbrk(add); + long add = sbrked_remains; + char *newcp; + + if (sbrked_remains) { /* Put rest into chain, we + cannot use it right now. */ + add_to_chain((void*)(last_sbrk_top - sbrked_remains), + sbrked_remains, 0); + } + + /* Second, check alignment. */ + slack = 0; + + /* WANTED_ALIGNMENT may be more than NEEDED_ALIGNMENT, but this may + improve performance of memory access. */ + if (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)) { /* Not aligned. */ + slack = WANTED_ALIGNMENT - (PTR2UV(cp) & (WANTED_ALIGNMENT - 1)); + add += slack; + } + + if (add) { + DEBUG_m(PerlIO_printf(Perl_debug_log, + "sbrk(%ld) to fix non-continuous/off-page sbrk:\n\t%ld for alignment,\t%ld were assumed to come from the tail of the previous sbrk\n", + (long)add, (long) slack, + (long) sbrked_remains)); + newcp = (char *)sbrk(add); #if defined(DEBUGGING_MSTATS) - sbrks++; - sbrk_slack += add; + sbrks++; + sbrk_slack += add; #endif - if (newcp != cp + require) { - /* Too bad: even rounding sbrk() is not continuous.*/ - DEBUG_m(PerlIO_printf(Perl_debug_log, - "failed to fix bad sbrk()\n")); + if (newcp != cp + require) { + /* Too bad: even rounding sbrk() is not continuous.*/ + DEBUG_m(PerlIO_printf(Perl_debug_log, + "failed to fix bad sbrk()\n")); #ifdef PACK_MALLOC - if (slack) { - MALLOC_UNLOCK; - fatalcroak("panic: Off-page sbrk\n"); - } + if (slack) { + MALLOC_UNLOCK; + fatalcroak("panic: Off-page sbrk\n"); + } #endif - if (sbrked_remains) { - /* Try again. */ + if (sbrked_remains) { + /* Try again. */ #if defined(DEBUGGING_MSTATS) - sbrk_slack += require; + sbrk_slack += require; #endif - require = needed; - DEBUG_m(PerlIO_printf(Perl_debug_log, - "straight sbrk(%ld)\n", - (long)require)); - cp = (char *)sbrk(require); + require = needed; + DEBUG_m(PerlIO_printf(Perl_debug_log, + "straight sbrk(%ld)\n", + (long)require)); + cp = (char *)sbrk(require); #ifdef DEBUGGING_MSTATS - sbrks++; + sbrks++; #endif - if (cp == (char *)-1) - return 0; - } - sbrk_goodness = -1; /* Disable optimization! - Continue with not-aligned... */ - } else { - cp += slack; - require += sbrked_remains; - } - } - - if (last_sbrk_top) { - sbrk_goodness -= SBRK_FAILURE_PRICE; - } - - ovp = (union overhead *) cp; - /* - * Round up to minimum allocation size boundary - * and deduct from block count to reflect. - */ + if (cp == (char *)-1) + return 0; + } + sbrk_goodness = -1; /* Disable optimization! + Continue with not-aligned... */ + } else { + cp += slack; + require += sbrked_remains; + } + } + + if (last_sbrk_top) { + sbrk_goodness -= SBRK_FAILURE_PRICE; + } + + ovp = (union overhead *) cp; + /* + * Round up to minimum allocation size boundary + * and deduct from block count to reflect. + */ # if NEEDED_ALIGNMENT > MEM_ALIGNBYTES - if (PTR2UV(ovp) & (NEEDED_ALIGNMENT - 1)) - fatalcroak("Misalignment of sbrk()\n"); - else + if (PTR2UV(ovp) & (NEEDED_ALIGNMENT - 1)) + fatalcroak("Misalignment of sbrk()\n"); + else # endif - if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) { - DEBUG_m(PerlIO_printf(Perl_debug_log, - "fixing sbrk(): %d bytes off machine alignment\n", - (int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)))); - ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) & - (MEM_ALIGNBYTES - 1)); - (*nblksp)--; + if (PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)) { + DEBUG_m(PerlIO_printf(Perl_debug_log, + "fixing sbrk(): %d bytes off machine alignment\n", + (int)(PTR2UV(ovp) & (MEM_ALIGNBYTES - 1)))); + ovp = INT2PTR(union overhead *,(PTR2UV(ovp) + MEM_ALIGNBYTES) & + (MEM_ALIGNBYTES - 1)); + (*nblksp)--; # if defined(DEBUGGING_MSTATS) - /* This is only approx. if TWO_POT_OPTIMIZE: */ - sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT)); + /* This is only approx. if TWO_POT_OPTIMIZE: */ + sbrk_slack += (1 << (bucket >> BUCKET_POW2_SHIFT)); # endif - } - ; /* Finish "else" */ - sbrked_remains = require - needed; - last_op = cp; + } + ; /* Finish "else" */ + sbrked_remains = require - needed; + last_op = cp; } #if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC) emergency_buffer_last_req = 0; @@ -1620,40 +1620,40 @@ static int getpages_adjacent(MEM_SIZE require) { if (require <= sbrked_remains) { - sbrked_remains -= require; + sbrked_remains -= require; } else { - char *cp; + char *cp; - require -= sbrked_remains; - /* We do not try to optimize sbrks here, we go for place. */ - cp = (char*) sbrk(require); + require -= sbrked_remains; + /* We do not try to optimize sbrks here, we go for place. */ + cp = (char*) sbrk(require); #ifdef DEBUGGING_MSTATS - sbrks++; - goodsbrk += require; + sbrks++; + goodsbrk += require; #endif - if (cp == last_sbrk_top) { - sbrked_remains = 0; - last_sbrk_top = cp + require; - } else { - if (cp == (char*)-1) { /* Out of memory */ + if (cp == last_sbrk_top) { + sbrked_remains = 0; + last_sbrk_top = cp + require; + } else { + if (cp == (char*)-1) { /* Out of memory */ #ifdef DEBUGGING_MSTATS - goodsbrk -= require; + goodsbrk -= require; #endif - return 0; - } - /* Report the failure: */ - if (sbrked_remains) - add_to_chain((void*)(last_sbrk_top - sbrked_remains), - sbrked_remains, 0); - add_to_chain((void*)cp, require, 0); - sbrk_goodness -= SBRK_FAILURE_PRICE; - sbrked_remains = 0; - last_sbrk_top = 0; - last_op = 0; - return 0; - } + return 0; + } + /* Report the failure: */ + if (sbrked_remains) + add_to_chain((void*)(last_sbrk_top - sbrked_remains), + sbrked_remains, 0); + add_to_chain((void*)cp, require, 0); + sbrk_goodness -= SBRK_FAILURE_PRICE; + sbrked_remains = 0; + last_sbrk_top = 0; + last_op = 0; + return 0; + } } - + return 1; } @@ -1663,227 +1663,227 @@ getpages_adjacent(MEM_SIZE require) static void morecore(int bucket) { - union overhead *ovp; - int rnu; /* 2^rnu bytes will be requested */ - int nblks; /* become nblks blocks of the desired size */ - MEM_SIZE siz, needed; - static int were_called = 0; - - if (nextf[bucket]) - return; + union overhead *ovp; + int rnu; /* 2^rnu bytes will be requested */ + int nblks; /* become nblks blocks of the desired size */ + MEM_SIZE siz, needed; + static int were_called = 0; + + if (nextf[bucket]) + return; #ifndef NO_PERL_MALLOC_ENV - if (!were_called) { - /* It's our first time. Initialize ourselves */ - were_called = 1; /* Avoid a loop */ - if (!MallocCfg[MallocCfg_skip_cfg_env]) { - char *s = getenv("PERL_MALLOC_OPT"), *t = s; + if (!were_called) { + /* It's our first time. Initialize ourselves */ + were_called = 1; /* Avoid a loop */ + if (!MallocCfg[MallocCfg_skip_cfg_env]) { + char *s = getenv("PERL_MALLOC_OPT"), *t = s; const char *off; - const char *opts = PERL_MALLOC_OPT_CHARS; - int changed = 0; - - while ( t && t[0] && t[1] == '=' - && ((off = strchr(opts, *t))) ) { - IV val = 0; - - t += 2; - while (isDIGIT(*t)) - val = 10*val + *t++ - '0'; - if (!*t || *t == ';') { - if (MallocCfg[off - opts] != val) - changed = 1; - MallocCfg[off - opts] = val; - if (*t) - t++; - } - } - if (t && *t) { - dTHX; - MYMALLOC_WRITE2STDERR("Unrecognized part of PERL_MALLOC_OPT: \""); - MYMALLOC_WRITE2STDERR(t); - MYMALLOC_WRITE2STDERR("\"\n"); - } - if (changed) - MallocCfg[MallocCfg_cfg_env_read] = 1; - } - } + const char *opts = PERL_MALLOC_OPT_CHARS; + int changed = 0; + + while ( t && t[0] && t[1] == '=' + && ((off = strchr(opts, *t))) ) { + IV val = 0; + + t += 2; + while (isDIGIT(*t)) + val = 10*val + *t++ - '0'; + if (!*t || *t == ';') { + if (MallocCfg[off - opts] != val) + changed = 1; + MallocCfg[off - opts] = val; + if (*t) + t++; + } + } + if (t && *t) { + dTHX; + MYMALLOC_WRITE2STDERR("Unrecognized part of PERL_MALLOC_OPT: \""); + MYMALLOC_WRITE2STDERR(t); + MYMALLOC_WRITE2STDERR("\"\n"); + } + if (changed) + MallocCfg[MallocCfg_cfg_env_read] = 1; + } + } #endif - if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) { - MALLOC_UNLOCK; - croak("%s", "Out of memory during ridiculously large request"); - } - if (bucket > max_bucket) - max_bucket = bucket; - - rnu = ( (bucket <= (LOG_OF_MIN_ARENA << BUCKET_POW2_SHIFT)) - ? LOG_OF_MIN_ARENA - : (bucket >> BUCKET_POW2_SHIFT) ); - /* This may be overwritten later: */ - nblks = 1 << (rnu - (bucket >> BUCKET_POW2_SHIFT)); /* how many blocks to get */ - needed = ((MEM_SIZE)1 << rnu) + POW2_OPTIMIZE_SURPLUS(bucket); - if (nextf[rnu << BUCKET_POW2_SHIFT]) { /* 2048b bucket. */ - ovp = nextf[rnu << BUCKET_POW2_SHIFT] - 1 + CHUNK_SHIFT; - nextf[rnu << BUCKET_POW2_SHIFT] - = nextf[rnu << BUCKET_POW2_SHIFT]->ov_next; + if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) { + MALLOC_UNLOCK; + croak("%s", "Out of memory during ridiculously large request"); + } + if (bucket > max_bucket) + max_bucket = bucket; + + rnu = ( (bucket <= (LOG_OF_MIN_ARENA << BUCKET_POW2_SHIFT)) + ? LOG_OF_MIN_ARENA + : (bucket >> BUCKET_POW2_SHIFT) ); + /* This may be overwritten later: */ + nblks = 1 << (rnu - (bucket >> BUCKET_POW2_SHIFT)); /* how many blocks to get */ + needed = ((MEM_SIZE)1 << rnu) + POW2_OPTIMIZE_SURPLUS(bucket); + if (nextf[rnu << BUCKET_POW2_SHIFT]) { /* 2048b bucket. */ + ovp = nextf[rnu << BUCKET_POW2_SHIFT] - 1 + CHUNK_SHIFT; + nextf[rnu << BUCKET_POW2_SHIFT] + = nextf[rnu << BUCKET_POW2_SHIFT]->ov_next; #ifdef DEBUGGING_MSTATS - nmalloc[rnu << BUCKET_POW2_SHIFT]--; - start_slack -= M_OVERHEAD; + nmalloc[rnu << BUCKET_POW2_SHIFT]--; + start_slack -= M_OVERHEAD; #endif - DEBUG_m(PerlIO_printf(Perl_debug_log, - "stealing %ld bytes from %ld arena\n", - (long) needed, (long) rnu << BUCKET_POW2_SHIFT)); - } else if (chunk_chain - && (ovp = (union overhead*) get_from_chain(needed))) { - DEBUG_m(PerlIO_printf(Perl_debug_log, - "stealing %ld bytes from chain\n", - (long) needed)); - } else if ( (ovp = (union overhead*) - get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1, - needed)) ) { - DEBUG_m(PerlIO_printf(Perl_debug_log, - "stealing %ld bytes from bigger buckets\n", - (long) needed)); - } else if (needed <= sbrked_remains) { - ovp = (union overhead *)(last_sbrk_top - sbrked_remains); - sbrked_remains -= needed; - last_op = (char*)ovp; - } else - ovp = getpages(needed, &nblks, bucket); - - if (!ovp) - return; - FILL_DEADBEEF((unsigned char*)ovp, needed); - - /* - * Add new memory allocated to that on - * free list for this hash bucket. - */ - siz = BUCKET_SIZE_NO_SURPLUS(bucket); /* No surplus if nblks > 1 */ + DEBUG_m(PerlIO_printf(Perl_debug_log, + "stealing %ld bytes from %ld arena\n", + (long) needed, (long) rnu << BUCKET_POW2_SHIFT)); + } else if (chunk_chain + && (ovp = (union overhead*) get_from_chain(needed))) { + DEBUG_m(PerlIO_printf(Perl_debug_log, + "stealing %ld bytes from chain\n", + (long) needed)); + } else if ( (ovp = (union overhead*) + get_from_bigger_buckets((rnu << BUCKET_POW2_SHIFT) + 1, + needed)) ) { + DEBUG_m(PerlIO_printf(Perl_debug_log, + "stealing %ld bytes from bigger buckets\n", + (long) needed)); + } else if (needed <= sbrked_remains) { + ovp = (union overhead *)(last_sbrk_top - sbrked_remains); + sbrked_remains -= needed; + last_op = (char*)ovp; + } else + ovp = getpages(needed, &nblks, bucket); + + if (!ovp) + return; + FILL_DEADBEEF((unsigned char*)ovp, needed); + + /* + * Add new memory allocated to that on + * free list for this hash bucket. + */ + siz = BUCKET_SIZE_NO_SURPLUS(bucket); /* No surplus if nblks > 1 */ #ifdef PACK_MALLOC - *(u_char*)ovp = bucket; /* Fill index. */ - if (bucket <= MAX_PACKED) { - ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket)); - nblks = N_BLKS(bucket); + *(u_char*)ovp = bucket; /* Fill index. */ + if (bucket <= MAX_PACKED) { + ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket)); + nblks = N_BLKS(bucket); # ifdef DEBUGGING_MSTATS - start_slack += BLK_SHIFT(bucket); + start_slack += BLK_SHIFT(bucket); # endif - } else if (bucket < LOG_OF_MIN_ARENA * BUCKETS_PER_POW2) { - ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket)); - siz -= sizeof(union overhead); - } else ovp++; /* One chunk per block. */ + } else if (bucket < LOG_OF_MIN_ARENA * BUCKETS_PER_POW2) { + ovp = (union overhead *) ((char*)ovp + BLK_SHIFT(bucket)); + siz -= sizeof(union overhead); + } else ovp++; /* One chunk per block. */ #endif /* PACK_MALLOC */ - nextf[bucket] = ovp; + nextf[bucket] = ovp; #ifdef DEBUGGING_MSTATS - nmalloc[bucket] += nblks; - if (bucket > MAX_PACKED) { - start_slack += M_OVERHEAD * nblks; - } + nmalloc[bucket] += nblks; + if (bucket > MAX_PACKED) { + start_slack += M_OVERHEAD * nblks; + } #endif - while (--nblks > 0) { - ovp->ov_next = (union overhead *)((caddr_t)ovp + siz); - ovp = (union overhead *)((caddr_t)ovp + siz); - } - /* Not all sbrks return zeroed memory.*/ - ovp->ov_next = (union overhead *)NULL; + while (--nblks > 0) { + ovp->ov_next = (union overhead *)((caddr_t)ovp + siz); + ovp = (union overhead *)((caddr_t)ovp + siz); + } + /* Not all sbrks return zeroed memory.*/ + ovp->ov_next = (union overhead *)NULL; #ifdef PACK_MALLOC - if (bucket == 7*BUCKETS_PER_POW2) { /* Special case, explanation is above. */ - union overhead *n_op = nextf[7*BUCKETS_PER_POW2]->ov_next; - nextf[7*BUCKETS_PER_POW2] = - (union overhead *)((caddr_t)nextf[7*BUCKETS_PER_POW2] - - sizeof(union overhead)); - nextf[7*BUCKETS_PER_POW2]->ov_next = n_op; - } + if (bucket == 7*BUCKETS_PER_POW2) { /* Special case, explanation is above. */ + union overhead *n_op = nextf[7*BUCKETS_PER_POW2]->ov_next; + nextf[7*BUCKETS_PER_POW2] = + (union overhead *)((caddr_t)nextf[7*BUCKETS_PER_POW2] + - sizeof(union overhead)); + nextf[7*BUCKETS_PER_POW2]->ov_next = n_op; + } #endif /* !PACK_MALLOC */ } Free_t Perl_mfree(Malloc_t where) { - MEM_SIZE size; - union overhead *ovp; - char *cp = (char*)where; + MEM_SIZE size; + union overhead *ovp; + char *cp = (char*)where; #ifdef PACK_MALLOC - u_char bucket; + u_char bucket; #endif - DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%" UVxf ": (%05lu) free\n", - PTR2UV(cp), (unsigned long)(PL_an++))); + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%" UVxf ": (%05lu) free\n", + PTR2UV(cp), (unsigned long)(PL_an++))); - if (cp == NULL) - return; + if (cp == NULL) + return; #ifdef DEBUGGING - if (PTR2UV(cp) & (MEM_ALIGNBYTES - 1)) - croak("%s", "wrong alignment in free()"); + if (PTR2UV(cp) & (MEM_ALIGNBYTES - 1)) + croak("%s", "wrong alignment in free()"); #endif - ovp = (union overhead *)((caddr_t)cp - - sizeof (union overhead) * CHUNK_SHIFT); + ovp = (union overhead *)((caddr_t)cp + - sizeof (union overhead) * CHUNK_SHIFT); #ifdef PACK_MALLOC - bucket = OV_INDEX(ovp); + bucket = OV_INDEX(ovp); #endif #ifdef IGNORE_SMALL_BAD_FREE - if ((bucket >= FIRST_BUCKET_WITH_CHECK) - && (OV_MAGIC(ovp, bucket) != MAGIC)) + if ((bucket >= FIRST_BUCKET_WITH_CHECK) + && (OV_MAGIC(ovp, bucket) != MAGIC)) #else - if (OV_MAGIC(ovp, bucket) != MAGIC) + if (OV_MAGIC(ovp, bucket) != MAGIC) #endif - { - static int bad_free_warn = -1; - if (bad_free_warn == -1) { - dTHX; - char *pbf = PerlEnv_getenv("PERL_BADFREE"); - bad_free_warn = (pbf) ? strNE("0", pbf) : 1; - } - if (!bad_free_warn) - return; + { + static int bad_free_warn = -1; + if (bad_free_warn == -1) { + dTHX; + char *pbf = PerlEnv_getenv("PERL_BADFREE"); + bad_free_warn = (pbf) ? strNE("0", pbf) : 1; + } + if (!bad_free_warn) + return; #ifdef RCHECK - { - dTHX; - if (!PERL_IS_ALIVE || !PL_curcop) - Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)", - ovp->ov_rmagic == RMAGIC - 1 ? - "Duplicate" : "Bad"); - } + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)", + ovp->ov_rmagic == RMAGIC - 1 ? + "Duplicate" : "Bad"); + } #else - { - dTHX; - if (!PERL_IS_ALIVE || !PL_curcop) - Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)"); - } + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)"); + } #endif - return; /* sanity */ - } + return; /* sanity */ + } #ifdef RCHECK - ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite"); - if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { - int i; - MEM_SIZE nbytes = ovp->ov_size + 1; - - if ((i = nbytes & (RMAGIC_SZ-1))) { - i = RMAGIC_SZ - i; - while (i--) { /* nbytes - RMAGIC_SZ is end of alloced area */ - ASSERT(((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] == RMAGIC_C, - "chunk's tail overwrite"); - } - } - /* Same at RMAGIC_SZ-aligned RMAGIC */ - nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1); - ASSERT(((u_int *)((caddr_t)ovp + nbytes))[-1] == RMAGIC, - "chunk's tail overwrite"); - FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes), - BUCKET_SIZE(OV_INDEX(ovp)) - nbytes); - } - FILL_DEADBEEF((unsigned char*)(ovp+CHUNK_SHIFT), - BUCKET_SIZE_REAL(OV_INDEX(ovp)) + RMAGIC_SZ); - ovp->ov_rmagic = RMAGIC - 1; + ASSERT(ovp->ov_rmagic == RMAGIC, "chunk's head overwrite"); + if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { + int i; + MEM_SIZE nbytes = ovp->ov_size + 1; + + if ((i = nbytes & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) { /* nbytes - RMAGIC_SZ is end of alloced area */ + ASSERT(((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] == RMAGIC_C, + "chunk's tail overwrite"); + } + } + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1); + ASSERT(((u_int *)((caddr_t)ovp + nbytes))[-1] == RMAGIC, + "chunk's tail overwrite"); + FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes), + BUCKET_SIZE(OV_INDEX(ovp)) - nbytes); + } + FILL_DEADBEEF((unsigned char*)(ovp+CHUNK_SHIFT), + BUCKET_SIZE_REAL(OV_INDEX(ovp)) + RMAGIC_SZ); + ovp->ov_rmagic = RMAGIC - 1; #endif - ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite"); - size = OV_INDEX(ovp); + ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite"); + size = OV_INDEX(ovp); - MALLOC_LOCK; - ovp->ov_next = nextf[size]; - nextf[size] = ovp; - MALLOC_UNLOCK; + MALLOC_LOCK; + ovp->ov_next = nextf[size]; + nextf[size] = ovp; + MALLOC_UNLOCK; } /* There is no need to do any locking in realloc (with an exception of @@ -1894,193 +1894,193 @@ Perl_mfree(Malloc_t where) Malloc_t Perl_realloc(void *mp, size_t nbytes) { - MEM_SIZE onb; - union overhead *ovp; - char *res; - int prev_bucket; - int bucket; - int incr; /* 1 if does not fit, -1 if "easily" fits in a - smaller bucket, otherwise 0. */ - char *cp = (char*)mp; + MEM_SIZE onb; + union overhead *ovp; + char *res; + int prev_bucket; + int bucket; + int incr; /* 1 if does not fit, -1 if "easily" fits in a + smaller bucket, otherwise 0. */ + char *cp = (char*)mp; #ifdef DEBUGGING - MEM_SIZE size = nbytes; + MEM_SIZE size = nbytes; - if ((long)nbytes < 0) - croak("%s", "panic: realloc"); + if ((long)nbytes < 0) + croak("%s", "panic: realloc"); #endif - BARK_64K_LIMIT("Reallocation",nbytes,size); - if (!cp) - return Perl_malloc(nbytes); + BARK_64K_LIMIT("Reallocation",nbytes,size); + if (!cp) + return Perl_malloc(nbytes); - ovp = (union overhead *)((caddr_t)cp - - sizeof (union overhead) * CHUNK_SHIFT); - bucket = OV_INDEX(ovp); + ovp = (union overhead *)((caddr_t)cp + - sizeof (union overhead) * CHUNK_SHIFT); + bucket = OV_INDEX(ovp); #ifdef IGNORE_SMALL_BAD_FREE - if ((bucket >= FIRST_BUCKET_WITH_CHECK) - && (OV_MAGIC(ovp, bucket) != MAGIC)) + if ((bucket >= FIRST_BUCKET_WITH_CHECK) + && (OV_MAGIC(ovp, bucket) != MAGIC)) #else - if (OV_MAGIC(ovp, bucket) != MAGIC) + if (OV_MAGIC(ovp, bucket) != MAGIC) #endif - { - static int bad_free_warn = -1; - if (bad_free_warn == -1) { - dTHX; - char *pbf = PerlEnv_getenv("PERL_BADFREE"); - bad_free_warn = (pbf) ? strNE("0", pbf) : 1; - } - if (!bad_free_warn) - return NULL; + { + static int bad_free_warn = -1; + if (bad_free_warn == -1) { + dTHX; + char *pbf = PerlEnv_getenv("PERL_BADFREE"); + bad_free_warn = (pbf) ? strNE("0", pbf) : 1; + } + if (!bad_free_warn) + return NULL; #ifdef RCHECK - { - dTHX; - if (!PERL_IS_ALIVE || !PL_curcop) - Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored", - (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "), - ovp->ov_rmagic == RMAGIC - 1 - ? "of freed memory " : ""); - } + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored", + (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "), + ovp->ov_rmagic == RMAGIC - 1 + ? "of freed memory " : ""); + } #else - { - dTHX; - if (!PERL_IS_ALIVE || !PL_curcop) - Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", - "Bad realloc() ignored"); - } + { + dTHX; + if (!PERL_IS_ALIVE || !PL_curcop) + Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", + "Bad realloc() ignored"); + } #endif - return NULL; /* sanity */ - } - - onb = BUCKET_SIZE_REAL(bucket); - /* - * avoid the copy if same size block. - * We are not aggressive with boundary cases. Note that it might - * (for a small number of cases) give false negative if - * both new size and old one are in the bucket for - * FIRST_BIG_POW2, but the new one is near the lower end. - * - * We do not try to go to 1.5 times smaller bucket so far. - */ - if (nbytes > onb) incr = 1; - else { + return NULL; /* sanity */ + } + + onb = BUCKET_SIZE_REAL(bucket); + /* + * avoid the copy if same size block. + * We are not aggressive with boundary cases. Note that it might + * (for a small number of cases) give false negative if + * both new size and old one are in the bucket for + * FIRST_BIG_POW2, but the new one is near the lower end. + * + * We do not try to go to 1.5 times smaller bucket so far. + */ + if (nbytes > onb) incr = 1; + else { #ifdef DO_NOT_TRY_HARDER_WHEN_SHRINKING - if ( /* This is a little bit pessimal if PACK_MALLOC: */ - nbytes > ( (onb >> 1) - M_OVERHEAD ) + if ( /* This is a little bit pessimal if PACK_MALLOC: */ + nbytes > ( (onb >> 1) - M_OVERHEAD ) # ifdef TWO_POT_OPTIMIZE - || (bucket == FIRST_BIG_POW2 && nbytes >= LAST_SMALL_BOUND ) + || (bucket == FIRST_BIG_POW2 && nbytes >= LAST_SMALL_BOUND ) # endif - ) + ) #else /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */ - prev_bucket = ( (bucket > MAX_PACKED + 1) - ? bucket - BUCKETS_PER_POW2 - : bucket - 1); - if (nbytes > BUCKET_SIZE_REAL(prev_bucket)) + prev_bucket = ( (bucket > MAX_PACKED + 1) + ? bucket - BUCKETS_PER_POW2 + : bucket - 1); + if (nbytes > BUCKET_SIZE_REAL(prev_bucket)) #endif /* !DO_NOT_TRY_HARDER_WHEN_SHRINKING */ - incr = 0; - else incr = -1; - } + incr = 0; + else incr = -1; + } #ifdef STRESS_REALLOC - goto hard_way; + goto hard_way; #endif - if (incr == 0) { - inplace_label: + if (incr == 0) { + inplace_label: #ifdef RCHECK - /* - * Record new allocated size of block and - * bound space with magic numbers. - */ - if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { - int i, nb = ovp->ov_size + 1; - - if ((i = nb & (RMAGIC_SZ-1))) { - i = RMAGIC_SZ - i; - while (i--) { /* nb - RMAGIC_SZ is end of alloced area */ - ASSERT(((caddr_t)ovp + nb - RMAGIC_SZ)[i] == RMAGIC_C, "chunk's tail overwrite"); - } - } - /* Same at RMAGIC_SZ-aligned RMAGIC */ - nb = (nb + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1); - ASSERT(((u_int *)((caddr_t)ovp + nb))[-1] == RMAGIC, - "chunk's tail overwrite"); - FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb), - BUCKET_SIZE(OV_INDEX(ovp)) - nb); - if (nbytes > ovp->ov_size + 1 - M_OVERHEAD) - FILL_FEEDADAD((unsigned char*)cp + ovp->ov_size + 1 - M_OVERHEAD, - nbytes - (ovp->ov_size + 1 - M_OVERHEAD)); - else - FILL_DEADBEEF((unsigned char*)cp + nbytes, - nb - M_OVERHEAD + RMAGIC_SZ - nbytes); - /* - * Convert amount of memory requested into - * closest block size stored in hash buckets - * which satisfies request. Account for - * space used per block for accounting. - */ - nbytes += M_OVERHEAD; - ovp->ov_size = nbytes - 1; - if ((i = nbytes & (RMAGIC_SZ-1))) { - i = RMAGIC_SZ - i; - while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */ - ((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] - = RMAGIC_C; - } - /* Same at RMAGIC_SZ-aligned RMAGIC */ - nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ - 1); - ((u_int *)((caddr_t)ovp + nbytes))[-1] = RMAGIC; - } + /* + * Record new allocated size of block and + * bound space with magic numbers. + */ + if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) { + int i, nb = ovp->ov_size + 1; + + if ((i = nb & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) { /* nb - RMAGIC_SZ is end of alloced area */ + ASSERT(((caddr_t)ovp + nb - RMAGIC_SZ)[i] == RMAGIC_C, "chunk's tail overwrite"); + } + } + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nb = (nb + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1); + ASSERT(((u_int *)((caddr_t)ovp + nb))[-1] == RMAGIC, + "chunk's tail overwrite"); + FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb), + BUCKET_SIZE(OV_INDEX(ovp)) - nb); + if (nbytes > ovp->ov_size + 1 - M_OVERHEAD) + FILL_FEEDADAD((unsigned char*)cp + ovp->ov_size + 1 - M_OVERHEAD, + nbytes - (ovp->ov_size + 1 - M_OVERHEAD)); + else + FILL_DEADBEEF((unsigned char*)cp + nbytes, + nb - M_OVERHEAD + RMAGIC_SZ - nbytes); + /* + * Convert amount of memory requested into + * closest block size stored in hash buckets + * which satisfies request. Account for + * space used per block for accounting. + */ + nbytes += M_OVERHEAD; + ovp->ov_size = nbytes - 1; + if ((i = nbytes & (RMAGIC_SZ-1))) { + i = RMAGIC_SZ - i; + while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */ + ((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] + = RMAGIC_C; + } + /* Same at RMAGIC_SZ-aligned RMAGIC */ + nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ - 1); + ((u_int *)((caddr_t)ovp + nbytes))[-1] = RMAGIC; + } #endif - res = cp; - DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%" UVxf ": (%05lu) realloc %ld bytes inplace\n", - PTR2UV(res),(unsigned long)(PL_an++), - (long)size)); - } else if (incr == 1 && (cp - M_OVERHEAD == last_op) - && (onb > (1 << LOG_OF_MIN_ARENA))) { - MEM_SIZE require, newarena = nbytes, pow; - int shiftr; - - POW2_OPTIMIZE_ADJUST(newarena); - newarena = newarena + M_OVERHEAD; - /* newarena = (newarena + 3) &~ 3; */ - shiftr = (newarena - 1) >> LOG_OF_MIN_ARENA; - pow = LOG_OF_MIN_ARENA + 1; - /* apart from this loop, this is O(1) */ - while (shiftr >>= 1) - pow++; - newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2); - require = newarena - onb - M_OVERHEAD; - - MALLOC_LOCK; - if (cp - M_OVERHEAD == last_op /* We *still* are the last chunk */ - && getpages_adjacent(require)) { + res = cp; + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%" UVxf ": (%05lu) realloc %ld bytes inplace\n", + PTR2UV(res),(unsigned long)(PL_an++), + (long)size)); + } else if (incr == 1 && (cp - M_OVERHEAD == last_op) + && (onb > (1 << LOG_OF_MIN_ARENA))) { + MEM_SIZE require, newarena = nbytes, pow; + int shiftr; + + POW2_OPTIMIZE_ADJUST(newarena); + newarena = newarena + M_OVERHEAD; + /* newarena = (newarena + 3) &~ 3; */ + shiftr = (newarena - 1) >> LOG_OF_MIN_ARENA; + pow = LOG_OF_MIN_ARENA + 1; + /* apart from this loop, this is O(1) */ + while (shiftr >>= 1) + pow++; + newarena = (1 << pow) + POW2_OPTIMIZE_SURPLUS(pow * BUCKETS_PER_POW2); + require = newarena - onb - M_OVERHEAD; + + MALLOC_LOCK; + if (cp - M_OVERHEAD == last_op /* We *still* are the last chunk */ + && getpages_adjacent(require)) { #ifdef DEBUGGING_MSTATS - nmalloc[bucket]--; - nmalloc[pow * BUCKETS_PER_POW2]++; + nmalloc[bucket]--; + nmalloc[pow * BUCKETS_PER_POW2]++; #endif - if (pow * BUCKETS_PER_POW2 > (MEM_SIZE)max_bucket) - max_bucket = pow * BUCKETS_PER_POW2; - *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */ - MALLOC_UNLOCK; - goto inplace_label; - } else { - MALLOC_UNLOCK; - goto hard_way; - } - } else { - hard_way: - DEBUG_m(PerlIO_printf(Perl_debug_log, - "0x%" UVxf ": (%05lu) realloc %ld bytes the hard way\n", - PTR2UV(cp),(unsigned long)(PL_an++), - (long)size)); - if ((res = (char*)Perl_malloc(nbytes)) == NULL) - return (NULL); - if (cp != res) /* common optimization */ - Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char); - Perl_mfree(cp); - } - return ((Malloc_t)res); + if (pow * BUCKETS_PER_POW2 > (MEM_SIZE)max_bucket) + max_bucket = pow * BUCKETS_PER_POW2; + *(cp - M_OVERHEAD) = pow * BUCKETS_PER_POW2; /* Fill index. */ + MALLOC_UNLOCK; + goto inplace_label; + } else { + MALLOC_UNLOCK; + goto hard_way; + } + } else { + hard_way: + DEBUG_m(PerlIO_printf(Perl_debug_log, + "0x%" UVxf ": (%05lu) realloc %ld bytes the hard way\n", + PTR2UV(cp),(unsigned long)(PL_an++), + (long)size)); + if ((res = (char*)Perl_malloc(nbytes)) == NULL) + return (NULL); + if (cp != res) /* common optimization */ + Copy(cp, res, (MEM_SIZE)(nbytes<onb?nbytes:onb), char); + Perl_mfree(cp); + } + return ((Malloc_t)res); } Malloc_t @@ -2090,7 +2090,7 @@ Perl_calloc(size_t elements, size_t size) Malloc_t p = Perl_malloc(sz); if (p) { - memset((void*)p, 0, sz); + memset((void*)p, 0, sz); } return p; } @@ -2136,7 +2136,7 @@ MEM_SIZE Perl_malloced_size(void *p) { union overhead * const ovp = (union overhead *) - ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT); + ((caddr_t)p - sizeof (union overhead) * CHUNK_SHIFT); const int bucket = OV_INDEX(ovp); PERL_ARGS_ASSERT_MALLOCED_SIZE; @@ -2145,9 +2145,9 @@ Perl_malloced_size(void *p) /* The caller wants to have a complete control over the chunk, disable the memory checking inside the chunk. */ if (bucket <= MAX_SHORT_BUCKET) { - const MEM_SIZE size = BUCKET_SIZE_REAL(bucket); - ovp->ov_size = size + M_OVERHEAD - 1; - *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RMAGIC_SZ)) = RMAGIC; + const MEM_SIZE size = BUCKET_SIZE_REAL(bucket); + ovp->ov_size = size + M_OVERHEAD - 1; + *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RMAGIC_SZ)) = RMAGIC; } #endif return BUCKET_SIZE_REAL(bucket); @@ -2170,56 +2170,56 @@ int Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) { #ifdef DEBUGGING_MSTATS - int i, j; - union overhead *p; - struct chunk_chain_s* nextchain; - - PERL_ARGS_ASSERT_GET_MSTATS; - - buf->topbucket = buf->topbucket_ev = buf->topbucket_odd - = buf->totfree = buf->total = buf->total_chain = 0; - - buf->minbucket = MIN_BUCKET; - MALLOC_LOCK; - for (i = MIN_BUCKET ; i < NBUCKETS; i++) { - for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) - ; - if (i < buflen) { - buf->nfree[i] = j; - buf->ntotal[i] = nmalloc[i]; - } - buf->totfree += j * BUCKET_SIZE_REAL(i); - buf->total += nmalloc[i] * BUCKET_SIZE_REAL(i); - if (nmalloc[i]) { - i % 2 ? (buf->topbucket_odd = i) : (buf->topbucket_ev = i); - buf->topbucket = i; - } - } - nextchain = chunk_chain; - while (nextchain) { - buf->total_chain += nextchain->size; - nextchain = nextchain->next; - } - buf->total_sbrk = goodsbrk + sbrk_slack; - buf->sbrks = sbrks; - buf->sbrk_good = sbrk_goodness; - buf->sbrk_slack = sbrk_slack; - buf->start_slack = start_slack; - buf->sbrked_remains = sbrked_remains; - MALLOC_UNLOCK; - buf->nbuckets = NBUCKETS; - if (level) { - for (i = MIN_BUCKET ; i < NBUCKETS; i++) { - if (i >= buflen) - break; - buf->bucket_mem_size[i] = BUCKET_SIZE_NO_SURPLUS(i); - buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i); - } - } + int i, j; + union overhead *p; + struct chunk_chain_s* nextchain; + + PERL_ARGS_ASSERT_GET_MSTATS; + + buf->topbucket = buf->topbucket_ev = buf->topbucket_odd + = buf->totfree = buf->total = buf->total_chain = 0; + + buf->minbucket = MIN_BUCKET; + MALLOC_LOCK; + for (i = MIN_BUCKET ; i < NBUCKETS; i++) { + for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) + ; + if (i < buflen) { + buf->nfree[i] = j; + buf->ntotal[i] = nmalloc[i]; + } + buf->totfree += j * BUCKET_SIZE_REAL(i); + buf->total += nmalloc[i] * BUCKET_SIZE_REAL(i); + if (nmalloc[i]) { + i % 2 ? (buf->topbucket_odd = i) : (buf->topbucket_ev = i); + buf->topbucket = i; + } + } + nextchain = chunk_chain; + while (nextchain) { + buf->total_chain += nextchain->size; + nextchain = nextchain->next; + } + buf->total_sbrk = goodsbrk + sbrk_slack; + buf->sbrks = sbrks; + buf->sbrk_good = sbrk_goodness; + buf->sbrk_slack = sbrk_slack; + buf->start_slack = start_slack; + buf->sbrked_remains = sbrked_remains; + MALLOC_UNLOCK; + buf->nbuckets = NBUCKETS; + if (level) { + for (i = MIN_BUCKET ; i < NBUCKETS; i++) { + if (i >= buflen) + break; + buf->bucket_mem_size[i] = BUCKET_SIZE_NO_SURPLUS(i); + buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i); + } + } #else /* defined DEBUGGING_MSTATS */ - PerlIO_printf(Perl_error_log, "perl not compiled with DEBUGGING_MSTATS\n"); + PerlIO_printf(Perl_error_log, "perl not compiled with DEBUGGING_MSTATS\n"); #endif /* defined DEBUGGING_MSTATS */ - return 0; /* XXX unused */ + return 0; /* XXX unused */ } /* * mstats - print out statistics about malloc @@ -2232,72 +2232,72 @@ void Perl_dump_mstats(pTHX_ const char *s) { #ifdef DEBUGGING_MSTATS - int i; - perl_mstats_t buffer; - UV nf[NBUCKETS]; - UV nt[NBUCKETS]; + int i; + perl_mstats_t buffer; + UV nf[NBUCKETS]; + UV nt[NBUCKETS]; - PERL_ARGS_ASSERT_DUMP_MSTATS; + PERL_ARGS_ASSERT_DUMP_MSTATS; - buffer.nfree = nf; - buffer.ntotal = nt; - get_mstats(&buffer, NBUCKETS, 0); + buffer.nfree = nf; + buffer.ntotal = nt; + get_mstats(&buffer, NBUCKETS, 0); - if (s) - PerlIO_printf(Perl_error_log, - "Memory allocation statistics %s (buckets %" IVdf + if (s) + PerlIO_printf(Perl_error_log, + "Memory allocation statistics %s (buckets %" IVdf "(%" IVdf ")..%" IVdf "(%" IVdf ")\n", - s, - (IV)BUCKET_SIZE_REAL(MIN_BUCKET), - (IV)BUCKET_SIZE_NO_SURPLUS(MIN_BUCKET), - (IV)BUCKET_SIZE_REAL(buffer.topbucket), - (IV)BUCKET_SIZE_NO_SURPLUS(buffer.topbucket)); + s, + (IV)BUCKET_SIZE_REAL(MIN_BUCKET), + (IV)BUCKET_SIZE_NO_SURPLUS(MIN_BUCKET), + (IV)BUCKET_SIZE_REAL(buffer.topbucket), + (IV)BUCKET_SIZE_NO_SURPLUS(buffer.topbucket)); PerlIO_printf(Perl_error_log, "%8" IVdf " free:", buffer.totfree); - for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { - PerlIO_printf(Perl_error_log, - ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5" UVuf - : ((i < 12*BUCKETS_PER_POW2) ? " %3" UVuf + for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, + ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) + ? " %5" UVuf + : ((i < 12*BUCKETS_PER_POW2) ? " %3" UVuf : " %" UVuf)), - buffer.nfree[i]); - } + buffer.nfree[i]); + } #ifdef BUCKETS_ROOT2 - PerlIO_printf(Perl_error_log, "\n\t "); - for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { - PerlIO_printf(Perl_error_log, - ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5"UVuf - : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)), - buffer.nfree[i]); - } + PerlIO_printf(Perl_error_log, "\n\t "); + for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, + ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) + ? " %5"UVuf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"UVuf : " %"UVuf)), + buffer.nfree[i]); + } #endif PerlIO_printf(Perl_error_log, "\n%8" IVdf " used:", buffer.total - buffer.totfree); - for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { - PerlIO_printf(Perl_error_log, - ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5" IVdf - : ((i < 12*BUCKETS_PER_POW2) ? " %3" IVdf : " %" IVdf)), - buffer.ntotal[i] - buffer.nfree[i]); - } + for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, + ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) + ? " %5" IVdf + : ((i < 12*BUCKETS_PER_POW2) ? " %3" IVdf : " %" IVdf)), + buffer.ntotal[i] - buffer.nfree[i]); + } #ifdef BUCKETS_ROOT2 - PerlIO_printf(Perl_error_log, "\n\t "); - for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { - PerlIO_printf(Perl_error_log, - ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) - ? " %5"IVdf - : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), - buffer.ntotal[i] - buffer.nfree[i]); - } + PerlIO_printf(Perl_error_log, "\n\t "); + for (i = MIN_BUCKET + 1; i <= buffer.topbucket_odd; i += BUCKETS_PER_POW2) { + PerlIO_printf(Perl_error_log, + ((i < 8*BUCKETS_PER_POW2 || i == 10*BUCKETS_PER_POW2) + ? " %5"IVdf + : ((i < 12*BUCKETS_PER_POW2) ? " %3"IVdf : " %"IVdf)), + buffer.ntotal[i] - buffer.nfree[i]); + } #endif - PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %" IVdf "/%" IVdf ":%" + PerlIO_printf(Perl_error_log, "\nTotal sbrk(): %" IVdf "/%" IVdf ":%" IVdf ". Odd ends: pad+heads+chain+tail: %" IVdf "+%" IVdf "+%" IVdf "+%" IVdf ".\n", - buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good, - buffer.sbrk_slack, buffer.start_slack, - buffer.total_chain, buffer.sbrked_remains); + buffer.total_sbrk, buffer.sbrks, buffer.sbrk_good, + buffer.sbrk_slack, buffer.start_slack, + buffer.total_chain, buffer.sbrked_remains); #else /* DEBUGGING_MSTATS */ - PerlIO_printf(Perl_error_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",s); + PerlIO_printf(Perl_error_log, "%s: perl not compiled with DEBUGGING_MSTATS\n",s); #endif /* DEBUGGING_MSTATS */ } @@ -2341,15 +2341,15 @@ Perl_sbrk(int size) size = (size + 0x7ff) & ~0x7ff; #endif if (size <= Perl_sbrk_oldsize) { - got = Perl_sbrk_oldchunk; - Perl_sbrk_oldchunk += size; - Perl_sbrk_oldsize -= size; + got = Perl_sbrk_oldchunk; + Perl_sbrk_oldchunk += size; + Perl_sbrk_oldsize -= size; } else { if (size >= PERLSBRK_32_K) { - small = 0; + small = 0; } else { - size = PERLSBRK_64_K; - small = 1; + size = PERLSBRK_64_K; + small = 1; } # if NEEDED_ALIGNMENT > SYSTEM_ALLOC_ALIGNMENT size += NEEDED_ALIGNMENT - SYSTEM_ALLOC_ALIGNMENT; @@ -2359,9 +2359,9 @@ Perl_sbrk(int size) got = (got + NEEDED_ALIGNMENT - 1) & ~(NEEDED_ALIGNMENT - 1); # endif if (small) { - /* Chunk is small, register the rest for future allocs. */ - Perl_sbrk_oldchunk = got + reqsize; - Perl_sbrk_oldsize = size - reqsize; + /* Chunk is small, register the rest for future allocs. */ + Perl_sbrk_oldchunk = got + reqsize; + Perl_sbrk_oldsize = size - reqsize; } } @@ -306,9 +306,9 @@ Perl_sv_iv(pTHX_ SV *sv) PERL_ARGS_ASSERT_SV_IV; if (SvIOK(sv)) { - if (SvIsUV(sv)) - return (IV)SvUVX(sv); - return SvIVX(sv); + if (SvIsUV(sv)) + return (IV)SvUVX(sv); + return SvIVX(sv); } return sv_2iv(sv); } @@ -328,9 +328,9 @@ Perl_sv_uv(pTHX_ SV *sv) PERL_ARGS_ASSERT_SV_UV; if (SvIOK(sv)) { - if (SvIsUV(sv)) - return SvUVX(sv); - return (UV)SvIVX(sv); + if (SvIsUV(sv)) + return SvUVX(sv); + return (UV)SvIVX(sv); } return sv_2uv(sv); } @@ -350,7 +350,7 @@ Perl_sv_nv(pTHX_ SV *sv) PERL_ARGS_ASSERT_SV_NV; if (SvNOK(sv)) - return SvNVX(sv); + return SvNVX(sv); return sv_2nv(sv); } @@ -373,8 +373,8 @@ Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) PERL_ARGS_ASSERT_SV_PVN; if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); + *lp = SvCUR(sv); + return SvPVX(sv); } return sv_2pv(sv, lp); } @@ -386,8 +386,8 @@ Perl_sv_pvn_nomg(pTHX_ SV *sv, STRLEN *lp) PERL_ARGS_ASSERT_SV_PVN_NOMG; if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); + *lp = SvCUR(sv); + return SvPVX(sv); } return sv_2pv_flags(sv, lp, 0); } @@ -624,12 +624,12 @@ Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how) bool Perl_do_open(pTHX_ GV *gv, const char *name, I32 len, int as_raw, - int rawmode, int rawperm, PerlIO *supplied_fp) + int rawmode, int rawperm, PerlIO *supplied_fp) { PERL_ARGS_ASSERT_DO_OPEN; return do_openn(gv, name, len, as_raw, rawmode, rawperm, - supplied_fp, (SV **) NULL, 0); + supplied_fp, (SV **) NULL, 0); } bool @@ -760,14 +760,14 @@ Perl_save_list(pTHX_ SV **sarg, I32 maxsarg) PERL_ARGS_ASSERT_SAVE_LIST; for (i = 1; i <= maxsarg; i++) { - SV *sv; - SvGETMAGIC(sarg[i]); - sv = newSV(0); - sv_setsv_nomg(sv,sarg[i]); - SSCHECK(3); - SSPUSHPTR(sarg[i]); /* remember the pointer */ - SSPUSHPTR(sv); /* remember the value */ - SSPUSHUV(SAVEt_ITEM); + SV *sv; + SvGETMAGIC(sarg[i]); + sv = newSV(0); + sv_setsv_nomg(sv,sarg[i]); + SSCHECK(3); + SSPUSHPTR(sarg[i]); /* remember the pointer */ + SSPUSHPTR(sv); /* remember the value */ + SSPUSHUV(SAVEt_ITEM); } } @@ -817,8 +817,8 @@ C<unpackstring> instead. SSize_t 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) + const char *strbeg, const char *strend, char **new_s, I32 ocnt, + U32 flags) { PERL_ARGS_ASSERT_UNPACK_STR; @@ -870,7 +870,7 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, U32 hash) PERL_ARGS_ASSERT_HV_FETCH_ENT; return (HE *)hv_common(hv, keysv, NULL, 0, 0, - (lval ? HV_FETCH_LVALUE : 0), NULL, hash); + (lval ? HV_FETCH_LVALUE : 0), NULL, hash); } SV * @@ -879,15 +879,15 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) PERL_ARGS_ASSERT_HV_DELETE_ENT; return MUTABLE_SV(hv_common(hv, keysv, NULL, 0, 0, flags | HV_DELETE, NULL, - hash)); + hash)); } SV** Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash, - int flags) + int flags) { return (SV**) hv_common(hv, NULL, key, klen, flags, - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); } SV** @@ -897,14 +897,14 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash) int flags; if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; + klen = -klen_i32; + flags = HVhek_UTF8; } else { - klen = klen_i32; - flags = 0; + klen = klen_i32; + flags = 0; } return (SV **) hv_common(hv, NULL, key, klen, flags, - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); } bool @@ -916,11 +916,11 @@ Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32) PERL_ARGS_ASSERT_HV_EXISTS; if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; + klen = -klen_i32; + flags = HVhek_UTF8; } else { - klen = klen_i32; - flags = 0; + klen = klen_i32; + flags = 0; } return cBOOL(hv_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)); } @@ -934,15 +934,15 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval) PERL_ARGS_ASSERT_HV_FETCH; if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; + klen = -klen_i32; + flags = HVhek_UTF8; } else { - klen = klen_i32; - flags = 0; + klen = klen_i32; + flags = 0; } return (SV **) hv_common(hv, NULL, key, klen, flags, - lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) - : HV_FETCH_JUST_SV, NULL, 0); + lval ? (HV_FETCH_JUST_SV | HV_FETCH_LVALUE) + : HV_FETCH_JUST_SV, NULL, 0); } SV * @@ -954,14 +954,14 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags) PERL_ARGS_ASSERT_HV_DELETE; if (klen_i32 < 0) { - klen = -klen_i32; - k_flags = HVhek_UTF8; + klen = -klen_i32; + k_flags = HVhek_UTF8; } else { - klen = klen_i32; - k_flags = 0; + klen = klen_i32; + k_flags = 0; } return MUTABLE_SV(hv_common(hv, NULL, key, klen, k_flags, flags | HV_DELETE, - NULL, 0)); + NULL, 0)); } AV * @@ -103,8 +103,8 @@ S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) if (SvREFCNT(sv) > 0) { /* guard against sv getting freed midway through the mg clearing, * by holding a private reference for the duration. */ - SvREFCNT_inc_simple_void_NN(sv); - bumped = TRUE; + SvREFCNT_inc_simple_void_NN(sv); + bumped = TRUE; } SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix)); @@ -137,19 +137,19 @@ Perl_mg_magical(SV *sv) SvMAGICAL_off(sv); if ((mg = SvMAGIC(sv))) { - do { - const MGVTBL* const vtbl = mg->mg_virtual; - if (vtbl) { - if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) - SvGMAGICAL_on(sv); - if (vtbl->svt_set) - SvSMAGICAL_on(sv); - if (vtbl->svt_clear) - SvRMAGICAL_on(sv); - } - } while ((mg = mg->mg_moremagic)); - if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) - SvRMAGICAL_on(sv); + do { + const MGVTBL* const vtbl = mg->mg_virtual; + if (vtbl) { + if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) + SvGMAGICAL_on(sv); + if (vtbl->svt_set) + SvSMAGICAL_on(sv); + if (vtbl->svt_clear) + SvRMAGICAL_on(sv); + } + } while ((mg = mg->mg_moremagic)); + if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) + SvRMAGICAL_on(sv); } } @@ -181,13 +181,13 @@ Perl_mg_get(pTHX_ SV *sv) newmg = cur = head = mg = SvMAGIC(sv); while (mg) { - const MGVTBL * const vtbl = mg->mg_virtual; - MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */ + const MGVTBL * const vtbl = mg->mg_virtual; + MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */ - if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { + if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { - /* taint's mg get is so dumb it doesn't need flag saving */ - if (mg->mg_type != PERL_MAGIC_taint) { + /* taint's mg get is so dumb it doesn't need flag saving */ + if (mg->mg_type != PERL_MAGIC_taint) { taint_only = FALSE; if (!saved) { save_magic(mgs_ix, sv); @@ -195,23 +195,23 @@ Perl_mg_get(pTHX_ SV *sv) } } - vtbl->svt_get(aTHX_ sv, mg); - - /* guard against magic having been deleted - eg FETCH calling - * untie */ - if (!SvMAGIC(sv)) { - /* recalculate flags */ - (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); - break; - } - - /* recalculate flags if this entry was deleted. */ - if (mg->mg_flags & MGf_GSKIP) - (SSPTR(mgs_ix, MGS *))->mgs_flags &= - ~(SVs_GMG|SVs_SMG|SVs_RMG); - } - else if (vtbl == &PL_vtbl_utf8) { - /* get-magic can reallocate the PV, unless there's only taint + vtbl->svt_get(aTHX_ sv, mg); + + /* guard against magic having been deleted - eg FETCH calling + * untie */ + if (!SvMAGIC(sv)) { + /* recalculate flags */ + (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); + break; + } + + /* recalculate flags if this entry was deleted. */ + if (mg->mg_flags & MGf_GSKIP) + (SSPTR(mgs_ix, MGS *))->mgs_flags &= + ~(SVs_GMG|SVs_SMG|SVs_RMG); + } + else if (vtbl == &PL_vtbl_utf8) { + /* get-magic can reallocate the PV, unless there's only taint * magic */ if (taint_only) { MAGIC *mg2; @@ -228,32 +228,32 @@ Perl_mg_get(pTHX_ SV *sv) } if (!taint_only) magic_setutf8(sv, mg); - } - - mg = nextmg; - - if (have_new) { - /* Have we finished with the new entries we saw? Start again - where we left off (unless there are more new entries). */ - if (mg == head) { - have_new = 0; - mg = cur; - head = newmg; - } - } - - /* Were any new entries added? */ - if (!have_new && (newmg = SvMAGIC(sv)) != head) { - have_new = 1; - cur = mg; - mg = newmg; - /* recalculate flags */ - (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); - } + } + + mg = nextmg; + + if (have_new) { + /* Have we finished with the new entries we saw? Start again + where we left off (unless there are more new entries). */ + if (mg == head) { + have_new = 0; + mg = cur; + head = newmg; + } + } + + /* Were any new entries added? */ + if (!have_new && (newmg = SvMAGIC(sv)) != head) { + have_new = 1; + cur = mg; + mg = newmg; + /* recalculate flags */ + (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); + } } if (saved) - restore_magic(INT2PTR(void *, (IV)mgs_ix)); + restore_magic(INT2PTR(void *, (IV)mgs_ix)); return 0; } @@ -281,16 +281,16 @@ Perl_mg_set(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = nextmg) { const MGVTBL* vtbl = mg->mg_virtual; - nextmg = mg->mg_moremagic; /* it may delete itself */ - if (mg->mg_flags & MGf_GSKIP) { - mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ - (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); - } - if (PL_localizing == 2 - && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) - continue; - if (vtbl && vtbl->svt_set) - vtbl->svt_set(aTHX_ sv, mg); + nextmg = mg->mg_moremagic; /* it may delete itself */ + if (mg->mg_flags & MGf_GSKIP) { + mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ + (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG); + } + if (PL_localizing == 2 + && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) + continue; + if (vtbl && vtbl->svt_set) + vtbl->svt_set(aTHX_ sv, mg); } restore_magic(INT2PTR(void*, (IV)mgs_ix)); @@ -319,14 +319,14 @@ Perl_mg_length(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const MGVTBL * const vtbl = mg->mg_virtual; - if (vtbl && vtbl->svt_len) { + if (vtbl && vtbl->svt_len) { const I32 mgs_ix = SSNEW(sizeof(MGS)); - save_magic(mgs_ix, sv); - /* omit MGf_GSKIP -- not changed here */ - len = vtbl->svt_len(aTHX_ sv, mg); - restore_magic(INT2PTR(void*, (IV)mgs_ix)); - return len; - } + save_magic(mgs_ix, sv); + /* omit MGf_GSKIP -- not changed here */ + len = vtbl->svt_len(aTHX_ sv, mg); + restore_magic(INT2PTR(void*, (IV)mgs_ix)); + return len; + } } (void)SvPV_const(sv, len); @@ -342,24 +342,24 @@ Perl_mg_size(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const MGVTBL* const vtbl = mg->mg_virtual; - if (vtbl && vtbl->svt_len) { + if (vtbl && vtbl->svt_len) { const I32 mgs_ix = SSNEW(sizeof(MGS)); I32 len; - save_magic(mgs_ix, sv); - /* omit MGf_GSKIP -- not changed here */ - len = vtbl->svt_len(aTHX_ sv, mg); - restore_magic(INT2PTR(void*, (IV)mgs_ix)); - return len; - } + save_magic(mgs_ix, sv); + /* omit MGf_GSKIP -- not changed here */ + len = vtbl->svt_len(aTHX_ sv, mg); + restore_magic(INT2PTR(void*, (IV)mgs_ix)); + return len; + } } switch(SvTYPE(sv)) { - case SVt_PVAV: - return AvFILLp((const AV *) sv); /* Fallback to non-tied array */ - case SVt_PVHV: - /* FIXME */ - default: - Perl_croak(aTHX_ "Size magic not implemented"); + case SVt_PVAV: + return AvFILLp((const AV *) sv); /* Fallback to non-tied array */ + case SVt_PVHV: + /* FIXME */ + default: + Perl_croak(aTHX_ "Size magic not implemented"); } NOT_REACHED; /* NOTREACHED */ @@ -386,12 +386,12 @@ Perl_mg_clear(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = nextmg) { const MGVTBL* const vtbl = mg->mg_virtual; - /* omit GSKIP -- never set here */ + /* omit GSKIP -- never set here */ - nextmg = mg->mg_moremagic; /* it may delete itself */ + nextmg = mg->mg_moremagic; /* it may delete itself */ - if (vtbl && vtbl->svt_clear) - vtbl->svt_clear(aTHX_ sv, mg); + if (vtbl && vtbl->svt_clear) + vtbl->svt_clear(aTHX_ sv, mg); } restore_magic(INT2PTR(void*, (IV)mgs_ix)); @@ -404,13 +404,13 @@ S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags) assert(flags <= 1); if (sv) { - MAGIC *mg; + MAGIC *mg; - for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { - if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) { - return mg; - } - } + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { + if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) { + return mg; + } + } } return NULL; @@ -478,20 +478,20 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const MGVTBL* const vtbl = mg->mg_virtual; - if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){ - count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen); - } - else { - const char type = mg->mg_type; - if (isUPPER(type) && type != PERL_MAGIC_uvar) { - sv_magic(nsv, - (type == PERL_MAGIC_tied) - ? SvTIED_obj(sv, mg) + if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){ + count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen); + } + else { + const char type = mg->mg_type; + if (isUPPER(type) && type != PERL_MAGIC_uvar) { + sv_magic(nsv, + (type == PERL_MAGIC_tied) + ? SvTIED_obj(sv, mg) : mg->mg_obj, - toLOWER(type), key, klen); - count++; - } - } + toLOWER(type), key, klen); + count++; + } + } } return count; } @@ -519,30 +519,30 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) PERL_ARGS_ASSERT_MG_LOCALIZE; if (nsv == DEFSV) - return; + return; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { - const MGVTBL* const vtbl = mg->mg_virtual; - if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) - continue; - - if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local) - (void)vtbl->svt_local(aTHX_ nsv, mg); - else - sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl, - mg->mg_ptr, mg->mg_len); + const MGVTBL* const vtbl = mg->mg_virtual; + if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) + continue; + + if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local) + (void)vtbl->svt_local(aTHX_ nsv, mg); + else + sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl, + mg->mg_ptr, mg->mg_len); - /* container types should remain read-only across localization */ - SvFLAGS(nsv) |= SvREADONLY(sv); + /* container types should remain read-only across localization */ + SvFLAGS(nsv) |= SvREADONLY(sv); } if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) { - SvFLAGS(nsv) |= SvMAGICAL(sv); - if (setmagic) { - PL_localizing = 1; - SvSETMAGIC(nsv); - PL_localizing = 0; - } + SvFLAGS(nsv) |= SvMAGICAL(sv); + if (setmagic) { + PL_localizing = 1; + SvSETMAGIC(nsv); + PL_localizing = 0; + } } } @@ -552,7 +552,7 @@ S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg) { const MGVTBL* const vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_free) - vtbl->svt_free(aTHX_ sv, mg); + vtbl->svt_free(aTHX_ sv, mg); if (mg->mg_len > 0) Safefree(mg->mg_ptr); @@ -560,7 +560,7 @@ S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg) SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); if (mg->mg_flags & MGf_REFCOUNTED) - SvREFCNT_dec(mg->mg_obj); + SvREFCNT_dec(mg->mg_obj); Safefree(mg); } @@ -581,9 +581,9 @@ Perl_mg_free(pTHX_ SV *sv) PERL_ARGS_ASSERT_MG_FREE; for (mg = SvMAGIC(sv); mg; mg = moremagic) { - moremagic = mg->mg_moremagic; - mg_free_struct(sv, mg); - SvMAGIC_set(sv, moremagic); + moremagic = mg->mg_moremagic; + mg_free_struct(sv, mg); + SvMAGIC_set(sv, moremagic); } SvMAGIC_set(sv, NULL); SvMAGICAL_off(sv); @@ -604,21 +604,21 @@ Perl_mg_free_type(pTHX_ SV *sv, int how) MAGIC *mg, *prevmg, *moremg; PERL_ARGS_ASSERT_MG_FREE_TYPE; for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { - moremg = mg->mg_moremagic; - if (mg->mg_type == how) { + moremg = mg->mg_moremagic; + if (mg->mg_type == how) { MAGIC *newhead; - /* temporarily move to the head of the magic chain, in case - custom free code relies on this historical aspect of mg_free */ - if (prevmg) { - prevmg->mg_moremagic = moremg; - mg->mg_moremagic = SvMAGIC(sv); - SvMAGIC_set(sv, mg); - } - newhead = mg->mg_moremagic; - mg_free_struct(sv, mg); - SvMAGIC_set(sv, newhead); - mg = prevmg; - } + /* temporarily move to the head of the magic chain, in case + custom free code relies on this historical aspect of mg_free */ + if (prevmg) { + prevmg->mg_moremagic = moremg; + mg->mg_moremagic = SvMAGIC(sv); + SvMAGIC_set(sv, mg); + } + newhead = mg->mg_moremagic; + mg_free_struct(sv, mg); + SvMAGIC_set(sv, newhead); + mg = prevmg; + } } mg_magical(sv); } @@ -640,21 +640,21 @@ Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl) MAGIC *mg, *prevmg, *moremg; PERL_ARGS_ASSERT_MG_FREEEXT; for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { - MAGIC *newhead; - moremg = mg->mg_moremagic; - if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) { - /* temporarily move to the head of the magic chain, in case - custom free code relies on this historical aspect of mg_free */ - if (prevmg) { - prevmg->mg_moremagic = moremg; - mg->mg_moremagic = SvMAGIC(sv); - SvMAGIC_set(sv, mg); - } - newhead = mg->mg_moremagic; - mg_free_struct(sv, mg); - SvMAGIC_set(sv, newhead); - mg = prevmg; - } + MAGIC *newhead; + moremg = mg->mg_moremagic; + if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) { + /* temporarily move to the head of the magic chain, in case + custom free code relies on this historical aspect of mg_free */ + if (prevmg) { + prevmg->mg_moremagic = moremg; + mg->mg_moremagic = SvMAGIC(sv); + SvMAGIC_set(sv, mg); + } + newhead = mg->mg_moremagic; + mg_free_struct(sv, mg); + SvMAGIC_set(sv, newhead); + mg = prevmg; + } } mg_magical(sv); } @@ -670,19 +670,19 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm) { REGEXP * const rx = PM_GETRE(PL_curpm); - if (rx) { + if (rx) { const SSize_t n = (SSize_t)mg->mg_obj; if (n == '+') { /* @+ */ - /* return the number possible */ - return RX_NPARENS(rx); + /* return the number possible */ + return RX_NPARENS(rx); } else { /* @- @^CAPTURE @{^CAPTURE} */ - I32 paren = RX_LASTPAREN(rx); + I32 paren = RX_LASTPAREN(rx); - /* return the last filled */ - while ( paren >= 0 - && (RX_OFFS(rx)[paren].start == -1 - || RX_OFFS(rx)[paren].end == -1) ) - paren--; + /* return the last filled */ + while ( paren >= 0 + && (RX_OFFS(rx)[paren].start == -1 + || RX_OFFS(rx)[paren].end == -1) ) + paren--; if (n == '-') { /* @- */ return (U32)paren; @@ -691,7 +691,7 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) return paren >= 0 ? (U32)(paren-1) : (U32)-1; } } - } + } } return (U32)-1; @@ -706,42 +706,42 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm) { REGEXP * const rx = PM_GETRE(PL_curpm); - if (rx) { + if (rx) { const SSize_t n = (SSize_t)mg->mg_obj; /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */ const I32 paren = mg->mg_len + (n == '\003' ? 1 : 0); - SSize_t s; - SSize_t t; - if (paren < 0) - return 0; - if (paren <= (I32)RX_NPARENS(rx) && - (s = RX_OFFS(rx)[paren].start) != -1 && - (t = RX_OFFS(rx)[paren].end) != -1) - { - SSize_t i; + SSize_t s; + SSize_t t; + if (paren < 0) + return 0; + if (paren <= (I32)RX_NPARENS(rx) && + (s = RX_OFFS(rx)[paren].start) != -1 && + (t = RX_OFFS(rx)[paren].end) != -1) + { + SSize_t i; if (n == '+') /* @+ */ - i = t; + i = t; else if (n == '-') /* @- */ - i = s; + i = s; else { /* @^CAPTURE @{^CAPTURE} */ CALLREG_NUMBUF_FETCH(rx,paren,sv); return 0; } - if (RX_MATCH_UTF8(rx)) { - const char * const b = RX_SUBBEG(rx); - if (b) - i = RX_SUBCOFFSET(rx) + + if (RX_MATCH_UTF8(rx)) { + const char * const b = RX_SUBBEG(rx); + if (b) + i = RX_SUBCOFFSET(rx) + utf8_length((U8*)b, (U8*)(b-RX_SUBOFFSET(rx)+i)); - } + } - sv_setuv(sv, i); - return 0; - } - } + sv_setuv(sv, i); + return 0; + } + } } sv_set_undef(sv); return 0; @@ -764,10 +764,10 @@ Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) if (SvPOK(sv)) { \ STRLEN len = SvCUR(sv); \ char * const p = SvPVX(sv); \ - while (len > 0 && isSPACE(p[len-1])) \ - --len; \ - SvCUR_set(sv, len); \ - p[len] = '\0'; \ + while (len > 0 && isSPACE(p[len-1])) \ + --len; \ + SvCUR_set(sv, len); \ + p[len] = '\0'; \ } \ } STMT_END @@ -777,21 +777,21 @@ Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) PERL_ARGS_ASSERT_EMULATE_COP_IO; if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT))) - sv_set_undef(sv); + sv_set_undef(sv); else { SvPVCLEAR(sv); - SvUTF8_off(sv); - if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) { - SV *const value = cop_hints_fetch_pvs(c, "open<", 0); - assert(value); - sv_catsv(sv, value); - } - sv_catpvs(sv, "\0"); - if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) { - SV *const value = cop_hints_fetch_pvs(c, "open>", 0); - assert(value); - sv_catsv(sv, value); - } + SvUTF8_off(sv); + if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) { + SV *const value = cop_hints_fetch_pvs(c, "open<", 0); + assert(value); + sv_catsv(sv, value); + } + sv_catpvs(sv, "\0"); + if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) { + SV *const value = cop_hints_fetch_pvs(c, "open>", 0); + assert(value); + sv_catsv(sv, value); + } } } @@ -806,7 +806,7 @@ S_fixup_errno_string(pTHX_ SV* sv) assert(SvOK(sv)); if(strEQ(SvPVX(sv), "")) { - sv_catpv(sv, UNKNOWN_ERRNO_MSG); + sv_catpv(sv, UNKNOWN_ERRNO_MSG); } else { @@ -877,13 +877,13 @@ Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv) { char const *errstr; if(!tgtsv) - tgtsv = sv_newmortal(); + tgtsv = sv_newmortal(); errstr = my_strerror(errnum); if(errstr) { - sv_setpv(tgtsv, errstr); - fixup_errno_string(tgtsv); + sv_setpv(tgtsv, errstr); + fixup_errno_string(tgtsv); } else { - SvPVCLEAR(tgtsv); + SvPVCLEAR(tgtsv); } return tgtsv; } @@ -918,26 +918,26 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) nextchar = *remaining; switch (*mg->mg_ptr) { case '\001': /* ^A */ - if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); - else + if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); + else sv_set_undef(sv); - if (SvTAINTED(PL_bodytarget)) - SvTAINTED_on(sv); - break; + if (SvTAINTED(PL_bodytarget)) + SvTAINTED_on(sv); + break; case '\003': /* ^C, ^CHILD_ERROR_NATIVE */ - if (nextchar == '\0') { - sv_setiv(sv, (IV)PL_minus_c); - } - else if (strEQ(remaining, "HILD_ERROR_NATIVE")) { - sv_setiv(sv, (IV)STATUS_NATIVE); + if (nextchar == '\0') { + sv_setiv(sv, (IV)PL_minus_c); + } + else if (strEQ(remaining, "HILD_ERROR_NATIVE")) { + sv_setiv(sv, (IV)STATUS_NATIVE); } - break; + break; case '\004': /* ^D */ - sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); - break; + sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); + break; case '\005': /* ^E */ - if (nextchar != '\0') { + if (nextchar != '\0') { if (strEQ(remaining, "NCODING")) sv_set_undef(sv); break; @@ -987,13 +987,13 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) # endif SvRTRIM(sv); SvNOK_on(sv); /* what a wonderful hack! */ - break; + break; #endif /* End of platforms with special handling for $^E; others just fall through to $! */ /* FALLTHROUGH */ case '!': - { + { dSAVE_ERRNO; #ifdef VMS sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno)); @@ -1017,219 +1017,219 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SvPOK_off(sv); } RESTORE_ERRNO; - } + } - SvRTRIM(sv); - SvNOK_on(sv); /* what a wonderful hack! */ - break; + SvRTRIM(sv); + SvNOK_on(sv); /* what a wonderful hack! */ + break; case '\006': /* ^F */ if (nextchar == '\0') { sv_setiv(sv, (IV)PL_maxsysfd); } - break; + break; case '\007': /* ^GLOBAL_PHASE */ - if (strEQ(remaining, "LOBAL_PHASE")) { - sv_setpvn(sv, PL_phase_names[PL_phase], - strlen(PL_phase_names[PL_phase])); - } - break; + if (strEQ(remaining, "LOBAL_PHASE")) { + sv_setpvn(sv, PL_phase_names[PL_phase], + strlen(PL_phase_names[PL_phase])); + } + break; case '\010': /* ^H */ - sv_setuv(sv, PL_hints); - break; + sv_setuv(sv, PL_hints); + break; case '\011': /* ^I */ /* NOT \t in EBCDIC */ - sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */ - break; + sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */ + break; case '\014': /* ^LAST_FH */ - if (strEQ(remaining, "AST_FH")) { - if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) { - assert(isGV_with_GP(PL_last_in_gv)); - SV_CHECK_THINKFIRST_COW_DROP(sv); - prepare_SV_for_RV(sv); - SvOK_off(sv); - SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv)); - SvROK_on(sv); - sv_rvweaken(sv); - } - else + if (strEQ(remaining, "AST_FH")) { + if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) { + assert(isGV_with_GP(PL_last_in_gv)); + SV_CHECK_THINKFIRST_COW_DROP(sv); + prepare_SV_for_RV(sv); + SvOK_off(sv); + SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv)); + SvROK_on(sv); + sv_rvweaken(sv); + } + else sv_set_undef(sv); - } - break; + } + break; case '\017': /* ^O & ^OPEN */ - if (nextchar == '\0') { - sv_setpv(sv, PL_osname); - SvTAINTED_off(sv); - } - else if (strEQ(remaining, "PEN")) { - Perl_emulate_cop_io(aTHX_ &PL_compiling, sv); - } - break; + if (nextchar == '\0') { + sv_setpv(sv, PL_osname); + SvTAINTED_off(sv); + } + else if (strEQ(remaining, "PEN")) { + Perl_emulate_cop_io(aTHX_ &PL_compiling, sv); + } + break; case '\020': sv_setiv(sv, (IV)PL_perldb); - break; + break; case '\023': /* ^S */ - if (nextchar == '\0') { - if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING) - SvOK_off(sv); - else if (PL_in_eval) - sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); - else - sv_setiv(sv, 0); - } - else if (strEQ(remaining, "AFE_LOCALES")) { + if (nextchar == '\0') { + if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING) + SvOK_off(sv); + else if (PL_in_eval) + sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); + else + sv_setiv(sv, 0); + } + else if (strEQ(remaining, "AFE_LOCALES")) { #if ! defined(USE_ITHREADS) || defined(USE_THREAD_SAFE_LOCALE) - sv_setuv(sv, (UV) 1); + sv_setuv(sv, (UV) 1); #else - sv_setuv(sv, (UV) 0); + sv_setuv(sv, (UV) 0); #endif } - break; + break; case '\024': /* ^T */ - if (nextchar == '\0') { + if (nextchar == '\0') { #ifdef BIG_TIME sv_setnv(sv, PL_basetime); #else sv_setiv(sv, (IV)PL_basetime); #endif } - else if (strEQ(remaining, "AINT")) + else if (strEQ(remaining, "AINT")) sv_setiv(sv, TAINTING_get - ? (TAINT_WARN_get || PL_unsafe ? -1 : 1) - : 0); + ? (TAINT_WARN_get || PL_unsafe ? -1 : 1) + : 0); break; case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */ - if (strEQ(remaining, "NICODE")) - sv_setuv(sv, (UV) PL_unicode); - else if (strEQ(remaining, "TF8LOCALE")) - sv_setuv(sv, (UV) PL_utf8locale); - else if (strEQ(remaining, "TF8CACHE")) - sv_setiv(sv, (IV) PL_utf8cache); + if (strEQ(remaining, "NICODE")) + sv_setuv(sv, (UV) PL_unicode); + else if (strEQ(remaining, "TF8LOCALE")) + sv_setuv(sv, (UV) PL_utf8locale); + else if (strEQ(remaining, "TF8CACHE")) + sv_setiv(sv, (IV) PL_utf8cache); break; case '\027': /* ^W & $^WARNING_BITS */ - if (nextchar == '\0') - sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON)); - else if (strEQ(remaining, "ARNING_BITS")) { - if (PL_compiling.cop_warnings == pWARN_NONE) { - sv_setpvn(sv, WARN_NONEstring, WARNsize) ; - } - else if (PL_compiling.cop_warnings == pWARN_STD) { + if (nextchar == '\0') + sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON)); + else if (strEQ(remaining, "ARNING_BITS")) { + if (PL_compiling.cop_warnings == pWARN_NONE) { + sv_setpvn(sv, WARN_NONEstring, WARNsize) ; + } + else if (PL_compiling.cop_warnings == pWARN_STD) { goto set_undef; - } + } else if (PL_compiling.cop_warnings == pWARN_ALL) { - sv_setpvn(sv, WARN_ALLstring, WARNsize); - } + sv_setpvn(sv, WARN_ALLstring, WARNsize); + } else { - sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1), - *PL_compiling.cop_warnings); - } - } - break; + sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1), + *PL_compiling.cop_warnings); + } + } + break; case '+': - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - paren = RX_LASTPAREN(rx); - if (paren) + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + paren = RX_LASTPAREN(rx); + if (paren) goto do_numbuf_fetch; - } + } goto set_undef; case '\016': /* ^N */ - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - paren = RX_LASTCLOSEPAREN(rx); - if (paren) + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + paren = RX_LASTCLOSEPAREN(rx); + if (paren) goto do_numbuf_fetch; - } + } goto set_undef; case '.': - if (GvIO(PL_last_in_gv)) { - sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); - } - break; + if (GvIO(PL_last_in_gv)) { + sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); + } + break; case '?': - { - sv_setiv(sv, (IV)STATUS_CURRENT); + { + sv_setiv(sv, (IV)STATUS_CURRENT); #ifdef COMPLEX_STATUS - SvUPGRADE(sv, SVt_PVLV); - LvTARGOFF(sv) = PL_statusvalue; - LvTARGLEN(sv) = PL_statusvalue_vms; + SvUPGRADE(sv, SVt_PVLV); + LvTARGOFF(sv) = PL_statusvalue; + LvTARGLEN(sv) = PL_statusvalue_vms; #endif - } - break; + } + break; case '^': - if (GvIOp(PL_defoutgv)) - s = IoTOP_NAME(GvIOp(PL_defoutgv)); - if (s) - sv_setpv(sv,s); - else { - sv_setpv(sv,GvENAME(PL_defoutgv)); - sv_catpvs(sv,"_TOP"); - } - break; + if (GvIOp(PL_defoutgv)) + s = IoTOP_NAME(GvIOp(PL_defoutgv)); + if (s) + sv_setpv(sv,s); + else { + sv_setpv(sv,GvENAME(PL_defoutgv)); + sv_catpvs(sv,"_TOP"); + } + break; case '~': - if (GvIOp(PL_defoutgv)) - s = IoFMT_NAME(GvIOp(PL_defoutgv)); - if (!s) - s = GvENAME(PL_defoutgv); - sv_setpv(sv,s); - break; + if (GvIOp(PL_defoutgv)) + s = IoFMT_NAME(GvIOp(PL_defoutgv)); + if (!s) + s = GvENAME(PL_defoutgv); + sv_setpv(sv,s); + break; case '=': - if (GvIO(PL_defoutgv)) - sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); - break; + if (GvIO(PL_defoutgv)) + sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); + break; case '-': - if (GvIO(PL_defoutgv)) - sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); - break; + if (GvIO(PL_defoutgv)) + sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); + break; case '%': - if (GvIO(PL_defoutgv)) - sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); - break; + if (GvIO(PL_defoutgv)) + sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); + break; case ':': case '/': - break; + break; case '[': - sv_setiv(sv, 0); - break; + sv_setiv(sv, 0); + break; case '|': - if (GvIO(PL_defoutgv)) - sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); - break; + if (GvIO(PL_defoutgv)) + sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); + break; case '\\': - if (PL_ors_sv) - sv_copypv(sv, PL_ors_sv); - else + if (PL_ors_sv) + sv_copypv(sv, PL_ors_sv); + else goto set_undef; - break; + break; case '$': /* $$ */ - { - IV const pid = (IV)PerlProc_getpid(); - if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) { - /* never set manually, or at least not since last fork */ - sv_setiv(sv, pid); - /* never unsafe, even if reading in a tainted expression */ - SvTAINTED_off(sv); - } - /* else a value has been assigned manually, so do nothing */ - } - break; + { + IV const pid = (IV)PerlProc_getpid(); + if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) { + /* never set manually, or at least not since last fork */ + sv_setiv(sv, pid); + /* never unsafe, even if reading in a tainted expression */ + SvTAINTED_off(sv); + } + /* else a value has been assigned manually, so do nothing */ + } + break; case '<': sv_setuid(sv, PerlProc_getuid()); - break; + break; case '>': sv_setuid(sv, PerlProc_geteuid()); - break; + break; case '(': sv_setgid(sv, PerlProc_getgid()); - goto add_groups; + goto add_groups; case ')': sv_setgid(sv, PerlProc_getegid()); add_groups: #ifdef HAS_GETGROUPS - { - Groups_t *gary = NULL; + { + Groups_t *gary = NULL; I32 num_groups = getgroups(0, gary); if (num_groups > 0) { I32 i; @@ -1239,12 +1239,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]); Safefree(gary); } - } - (void)SvIOK_on(sv); /* what a wonderful hack! */ + } + (void)SvIOK_on(sv); /* what a wonderful hack! */ #endif - break; + break; case '0': - break; + break; } return 0; @@ -1261,7 +1261,7 @@ Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETUVAR; if (uf && uf->uf_val) - (*uf->uf_val)(aTHX_ uf->uf_index, sv); + (*uf->uf_val)(aTHX_ uf->uf_index, sv); return 0; } @@ -1293,76 +1293,76 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) /* We just undefd an environment var. Is a replacement */ /* waiting in the wings? */ if (!len) { - SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE); - if (valp) - s = SvOK(*valp) ? SvPV_const(*valp, len) : ""; + SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE); + if (valp) + s = SvOK(*valp) ? SvPV_const(*valp, len) : ""; } #endif #if !defined(OS2) && !defined(WIN32) && !defined(MSDOS) - /* And you'll never guess what the dog had */ - /* in its mouth... */ + /* And you'll never guess what the dog had */ + /* in its mouth... */ if (TAINTING_get) { - MgTAINTEDDIR_off(mg); + MgTAINTEDDIR_off(mg); #ifdef VMS - if (s && memEQs(key, klen, "DCL$PATH")) { - char pathbuf[256], eltbuf[256], *cp, *elt; - int i = 0, j = 0; - - my_strlcpy(eltbuf, s, sizeof(eltbuf)); - elt = eltbuf; - do { /* DCL$PATH may be a search list */ - while (1) { /* as may dev portion of any element */ - if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { - if ( *(cp+1) == '.' || *(cp+1) == '-' || - cando_by_name(S_IWUSR,0,elt) ) { - MgTAINTEDDIR_on(mg); - return 0; - } - } - if ((cp = strchr(elt, ':')) != NULL) - *cp = '\0'; - if (my_trnlnm(elt, eltbuf, j++)) - elt = eltbuf; - else - break; - } - j = 0; - } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); - } + if (s && memEQs(key, klen, "DCL$PATH")) { + char pathbuf[256], eltbuf[256], *cp, *elt; + int i = 0, j = 0; + + my_strlcpy(eltbuf, s, sizeof(eltbuf)); + elt = eltbuf; + do { /* DCL$PATH may be a search list */ + while (1) { /* as may dev portion of any element */ + if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { + if ( *(cp+1) == '.' || *(cp+1) == '-' || + cando_by_name(S_IWUSR,0,elt) ) { + MgTAINTEDDIR_on(mg); + return 0; + } + } + if ((cp = strchr(elt, ':')) != NULL) + *cp = '\0'; + if (my_trnlnm(elt, eltbuf, j++)) + elt = eltbuf; + else + break; + } + j = 0; + } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); + } #endif /* VMS */ - if (s && memEQs(key, klen, "PATH")) { - const char * const strend = s + len; + if (s && memEQs(key, klen, "PATH")) { + const char * const strend = s + len; /* set MGf_TAINTEDDIR if any component of the new path is * relative or world-writeable */ - while (s < strend) { - char tmpbuf[256]; - Stat_t st; - I32 i; + while (s < strend) { + char tmpbuf[256]; + Stat_t st; + I32 i; #ifdef __VMS /* Hmm. How do we get $Config{path_sep} from C? */ - const char path_sep = PL_perllib_sep; + const char path_sep = PL_perllib_sep; #else - const char path_sep = ':'; + const char path_sep = ':'; #endif - s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, - s, strend, path_sep, &i); - s++; - if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */ + s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, + s, strend, path_sep, &i); + s++; + if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */ #ifdef __VMS - /* no colon thus no device name -- assume relative path */ - || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':')) - /* Using Unix separator, e.g. under bash, so act line Unix */ - || (PL_perllib_sep == ':' && *tmpbuf != '/') + /* no colon thus no device name -- assume relative path */ + || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':')) + /* Using Unix separator, e.g. under bash, so act line Unix */ + || (PL_perllib_sep == ':' && *tmpbuf != '/') #else - || *tmpbuf != '/' /* no starting slash -- assume relative path */ + || *tmpbuf != '/' /* no starting slash -- assume relative path */ #endif - || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { - MgTAINTEDDIR_on(mg); - return 0; - } - } - } + || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { + MgTAINTEDDIR_on(mg); + return 0; + } + } + } } #endif /* neither OS2 nor WIN32 nor MSDOS */ @@ -1387,14 +1387,14 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else if (PL_localizing) { - HE* entry; - my_clearenv(); - hv_iterinit(MUTABLE_HV(sv)); - while ((entry = hv_iternext(MUTABLE_HV(sv)))) { - I32 keylen; - my_setenv(hv_iterkey(entry, &keylen), - SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry))); - } + HE* entry; + my_clearenv(); + hv_iterinit(MUTABLE_HV(sv)); + while ((entry = hv_iternext(MUTABLE_HV(sv)))) { + I32 keylen; + my_setenv(hv_iterkey(entry, &keylen), + SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry))); + } } #endif return 0; @@ -1438,26 +1438,26 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) } if (i > 0) { - if(PL_psig_ptr[i]) - sv_setsv(sv,PL_psig_ptr[i]); - else { - Sighandler_t sigstate = rsignal_state(i); + if(PL_psig_ptr[i]) + sv_setsv(sv,PL_psig_ptr[i]); + else { + Sighandler_t sigstate = rsignal_state(i); #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - if (PL_sig_handlers_initted && PL_sig_ignoring[i]) - sigstate = SIG_IGN; + if (PL_sig_handlers_initted && PL_sig_ignoring[i]) + sigstate = SIG_IGN; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - if (PL_sig_handlers_initted && PL_sig_defaulting[i]) - sigstate = SIG_DFL; + if (PL_sig_handlers_initted && PL_sig_defaulting[i]) + sigstate = SIG_DFL; #endif - /* cache state so we don't fetch it again */ - if(sigstate == (Sighandler_t) SIG_IGN) - sv_setpvs(sv,"IGNORE"); - else + /* cache state so we don't fetch it again */ + if(sigstate == (Sighandler_t) SIG_IGN) + sv_setpvs(sv,"IGNORE"); + else sv_set_undef(sv); - PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); - SvTEMP_off(sv); - } + PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); + SvTEMP_off(sv); + } } return 0; } @@ -1531,17 +1531,17 @@ Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSE #endif if ( #ifdef SIGILL - sig == SIGILL || + sig == SIGILL || #endif #ifdef SIGBUS - sig == SIGBUS || + sig == SIGBUS || #endif #ifdef SIGSEGV - sig == SIGSEGV || + sig == SIGSEGV || #endif - (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) - /* Call the perl level handler now-- - * with risk we may be in malloc() or being destructed etc. */ + (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) + /* Call the perl level handler now-- + * with risk we may be in malloc() or being destructed etc. */ { if (PL_sighandlerp == Perl_sighandler) /* default handler, so can call perly_sighandler() directly @@ -1557,18 +1557,18 @@ Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSE #endif } else { - if (!PL_psig_pend) return; - /* Set a flag to say this signal is pending, that is awaiting delivery after - * the current Perl opcode completes */ - PL_psig_pend[sig]++; + if (!PL_psig_pend) return; + /* Set a flag to say this signal is pending, that is awaiting delivery after + * the current Perl opcode completes */ + PL_psig_pend[sig]++; #ifndef SIG_PENDING_DIE_COUNT # define SIG_PENDING_DIE_COUNT 120 #endif - /* Add one to say _a_ signal is pending */ - if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT) - Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded", - (unsigned long)SIG_PENDING_DIE_COUNT); + /* Add one to say _a_ signal is pending */ + if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT) + Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded", + (unsigned long)SIG_PENDING_DIE_COUNT); } } @@ -1608,31 +1608,31 @@ Perl_despatch_signals(pTHX) int sig; PL_sig_pending = 0; for (sig = 1; sig < SIG_SIZE; sig++) { - if (PL_psig_pend[sig]) { - dSAVE_ERRNO; + if (PL_psig_pend[sig]) { + dSAVE_ERRNO; #ifdef HAS_SIGPROCMASK - /* From sigaction(2) (FreeBSD man page): - * | Signal routines normally execute with the signal that - * | caused their invocation blocked, but other signals may - * | yet occur. - * Emulation of this behavior (from within Perl) is enabled - * using sigprocmask - */ - int was_blocked; - sigset_t newset, oldset; - - sigemptyset(&newset); - sigaddset(&newset, sig); - sigprocmask(SIG_BLOCK, &newset, &oldset); - was_blocked = sigismember(&oldset, sig); - if (!was_blocked) { - SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t)); - ENTER; - SAVEFREESV(save_sv); - SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv)); - } -#endif - PL_psig_pend[sig] = 0; + /* From sigaction(2) (FreeBSD man page): + * | Signal routines normally execute with the signal that + * | caused their invocation blocked, but other signals may + * | yet occur. + * Emulation of this behavior (from within Perl) is enabled + * using sigprocmask + */ + int was_blocked; + sigset_t newset, oldset; + + sigemptyset(&newset); + sigaddset(&newset, sig); + sigprocmask(SIG_BLOCK, &newset, &oldset); + was_blocked = sigismember(&oldset, sig); + if (!was_blocked) { + SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t)); + ENTER; + SAVEFREESV(save_sv); + SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv)); + } +#endif + PL_psig_pend[sig] = 0; if (PL_sighandlerp == Perl_sighandler) /* default handler, so can call perly_sighandler() directly * rather than via Perl_sighandler, passing the extra @@ -1647,11 +1647,11 @@ Perl_despatch_signals(pTHX) #endif #ifdef HAS_SIGPROCMASK - if (!was_blocked) - LEAVE; + if (!was_blocked) + LEAVE; #endif - RESTORE_ERRNO; - } + RESTORE_ERRNO; + } } } @@ -1677,134 +1677,134 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if (*s == '_') { if (memEQs(s, len, "__DIE__")) - svp = &PL_diehook; - else if (memEQs(s, len, "__WARN__") - && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) { - /* Merge the existing behaviours, which are as follows: - magic_setsig, we always set svp to &PL_warnhook - (hence we always change the warnings handler) - For magic_clearsig, we don't change the warnings handler if it's - set to the &PL_warnhook. */ - svp = &PL_warnhook; + svp = &PL_diehook; + else if (memEQs(s, len, "__WARN__") + && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) { + /* Merge the existing behaviours, which are as follows: + magic_setsig, we always set svp to &PL_warnhook + (hence we always change the warnings handler) + For magic_clearsig, we don't change the warnings handler if it's + set to the &PL_warnhook. */ + svp = &PL_warnhook; } else if (sv) { SV *tmp = sv_newmortal(); Perl_croak(aTHX_ "No such hook: %s", pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); } - i = 0; - if (svp && *svp) { - if (*svp != PERL_WARNHOOK_FATAL) - to_dec = *svp; - *svp = NULL; - } + i = 0; + if (svp && *svp) { + if (*svp != PERL_WARNHOOK_FATAL) + to_dec = *svp; + *svp = NULL; + } } else { - i = (I16)mg->mg_private; - if (!i) { - i = whichsig_pvn(s, len); /* ...no, a brick */ - mg->mg_private = (U16)i; - } - if (i <= 0) { - if (sv) { + i = (I16)mg->mg_private; + if (!i) { + i = whichsig_pvn(s, len); /* ...no, a brick */ + mg->mg_private = (U16)i; + } + if (i <= 0) { + if (sv) { SV *tmp = sv_newmortal(); - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); } - return 0; - } + return 0; + } #ifdef HAS_SIGPROCMASK - /* Avoid having the signal arrive at a bad time, if possible. */ - sigemptyset(&set); - sigaddset(&set,i); - sigprocmask(SIG_BLOCK, &set, &save); - ENTER; - save_sv = newSVpvn((char *)(&save), sizeof(sigset_t)); - SAVEFREESV(save_sv); - SAVEDESTRUCTOR_X(restore_sigmask, save_sv); -#endif - PERL_ASYNC_CHECK(); + /* Avoid having the signal arrive at a bad time, if possible. */ + sigemptyset(&set); + sigaddset(&set,i); + sigprocmask(SIG_BLOCK, &set, &save); + ENTER; + save_sv = newSVpvn((char *)(&save), sizeof(sigset_t)); + SAVEFREESV(save_sv); + SAVEDESTRUCTOR_X(restore_sigmask, save_sv); +#endif + PERL_ASYNC_CHECK(); #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) - if (!PL_sig_handlers_initted) Perl_csighandler_init(); + if (!PL_sig_handlers_initted) Perl_csighandler_init(); #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - PL_sig_ignoring[i] = 0; + PL_sig_ignoring[i] = 0; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - PL_sig_defaulting[i] = 0; -#endif - to_dec = PL_psig_ptr[i]; - if (sv) { - PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); - SvTEMP_off(sv); /* Make sure it doesn't go away on us */ - - /* Signals don't change name during the program's execution, so once - they're cached in the appropriate slot of PL_psig_name, they can - stay there. - - Ideally we'd find some way of making SVs at (C) compile time, or - at least, doing most of the work. */ - if (!PL_psig_name[i]) { - const char* name = PL_sig_name[i]; - PL_psig_name[i] = newSVpvn(name, strlen(name)); - SvREADONLY_on(PL_psig_name[i]); - } - } else { - SvREFCNT_dec(PL_psig_name[i]); - PL_psig_name[i] = NULL; - PL_psig_ptr[i] = NULL; - } + PL_sig_defaulting[i] = 0; +#endif + to_dec = PL_psig_ptr[i]; + if (sv) { + PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); + SvTEMP_off(sv); /* Make sure it doesn't go away on us */ + + /* Signals don't change name during the program's execution, so once + they're cached in the appropriate slot of PL_psig_name, they can + stay there. + + Ideally we'd find some way of making SVs at (C) compile time, or + at least, doing most of the work. */ + if (!PL_psig_name[i]) { + const char* name = PL_sig_name[i]; + PL_psig_name[i] = newSVpvn(name, strlen(name)); + SvREADONLY_on(PL_psig_name[i]); + } + } else { + SvREFCNT_dec(PL_psig_name[i]); + PL_psig_name[i] = NULL; + PL_psig_ptr[i] = NULL; + } } if (sv && (isGV_with_GP(sv) || SvROK(sv))) { - if (i) { - (void)rsignal(i, PL_csighandlerp); - } - else - *svp = SvREFCNT_inc_simple_NN(sv); + if (i) { + (void)rsignal(i, PL_csighandlerp); + } + else + *svp = SvREFCNT_inc_simple_NN(sv); } else { - if (sv && SvOK(sv)) { - s = SvPV_force(sv, len); - } else { - sv = NULL; - } - if (sv && memEQs(s, len,"IGNORE")) { - if (i) { + if (sv && SvOK(sv)) { + s = SvPV_force(sv, len); + } else { + sv = NULL; + } + if (sv && memEQs(s, len,"IGNORE")) { + if (i) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - PL_sig_ignoring[i] = 1; - (void)rsignal(i, PL_csighandlerp); + PL_sig_ignoring[i] = 1; + (void)rsignal(i, PL_csighandlerp); #else - (void)rsignal(i, (Sighandler_t) SIG_IGN); + (void)rsignal(i, (Sighandler_t) SIG_IGN); #endif - } - } - else if (!sv || memEQs(s, len,"DEFAULT") || !len) { - if (i) { + } + } + else if (!sv || memEQs(s, len,"DEFAULT") || !len) { + if (i) { #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - PL_sig_defaulting[i] = 1; - (void)rsignal(i, PL_csighandlerp); + PL_sig_defaulting[i] = 1; + (void)rsignal(i, PL_csighandlerp); #else - (void)rsignal(i, (Sighandler_t) SIG_DFL); -#endif - } - } - else { - /* - * We should warn if HINT_STRICT_REFS, but without - * access to a known hint bit in a known OP, we can't - * tell whether HINT_STRICT_REFS is in force or not. - */ - if (!memchr(s, ':', len) && !memchr(s, '\'', len)) - Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), - SV_GMAGIC); - if (i) - (void)rsignal(i, PL_csighandlerp); - else - *svp = SvREFCNT_inc_simple_NN(sv); - } + (void)rsignal(i, (Sighandler_t) SIG_DFL); +#endif + } + } + else { + /* + * We should warn if HINT_STRICT_REFS, but without + * access to a known hint bit in a known OP, we can't + * tell whether HINT_STRICT_REFS is in force or not. + */ + if (!memchr(s, ':', len) && !memchr(s, '\'', len)) + Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), + SV_GMAGIC); + if (i) + (void)rsignal(i, PL_csighandlerp); + else + *svp = SvREFCNT_inc_simple_NN(sv); + } } #ifdef HAS_SIGPROCMASK if(i) - LEAVE; + LEAVE; #endif SvREFCNT_dec(to_dec); return 0; @@ -1819,7 +1819,7 @@ Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) /* Skip _isaelem because _isa will handle it shortly */ if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem) - return 0; + return 0; return magic_clearisa(NULL, mg); } @@ -1835,23 +1835,23 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) if(PL_phase == PERL_PHASE_DESTRUCT) return 0; if (sv) - av_clear(MUTABLE_AV(sv)); + av_clear(MUTABLE_AV(sv)); if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj)) - /* This occurs with setisa_elem magic, which calls this - same function. */ - mg = mg_find(mg->mg_obj, PERL_MAGIC_isa); + /* This occurs with setisa_elem magic, which calls this + same function. */ + mg = mg_find(mg->mg_obj, PERL_MAGIC_isa); assert(mg); if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */ - SV **svp = AvARRAY((AV *)mg->mg_obj); - I32 items = AvFILLp((AV *)mg->mg_obj) + 1; - while (items--) { - stash = GvSTASH((GV *)*svp++); - if (stash && HvENAME(stash)) mro_isa_changed_in(stash); - } + SV **svp = AvARRAY((AV *)mg->mg_obj); + I32 items = AvFILLp((AV *)mg->mg_obj) + 1; + while (items--) { + stash = GvSTASH((GV *)*svp++); + if (stash && HvENAME(stash)) mro_isa_changed_in(stash); + } - return 0; + return 0; } stash = GvSTASH( @@ -1861,7 +1861,7 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) /* The stash may have been detached from the symbol table, so check its name before doing anything. */ if (stash && HvENAME_get(stash)) - mro_isa_changed_in(stash); + mro_isa_changed_in(stash); return 0; } @@ -1878,10 +1878,10 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) if (hv) { (void) hv_iterinit(hv); if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) - i = HvUSEDKEYS(hv); + i = HvUSEDKEYS(hv); else { - while (hv_iternext(hv)) - i++; + while (hv_iternext(hv)) + i++; } } @@ -1895,7 +1895,7 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETNKEYS; PERL_UNUSED_ARG(mg); if (LvTARG(sv)) { - hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv)); + hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv)); } return 0; } @@ -1929,7 +1929,7 @@ Returns the SV (if any) returned by the method, or C<NULL> on failure. SV* Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, - U32 argc, ...) + U32 argc, ...) { dSP; SV* ret = NULL; @@ -1939,11 +1939,11 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, ENTER; if (flags & G_WRITING_TO_STDERR) { - SAVETMPS; + SAVETMPS; - save_re_context(); - SAVESPTR(PL_stderrgv); - PL_stderrgv = NULL; + save_re_context(); + SAVESPTR(PL_stderrgv); + PL_stderrgv = NULL; } PUSHSTACKi(PERLSI_MAGIC); @@ -1954,31 +1954,31 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, EXTEND(SP, (I32)argc+1); PUSHs(SvTIED_obj(sv, mg)); if (flags & G_UNDEF_FILL) { - while (argc--) { - PUSHs(&PL_sv_undef); - } + while (argc--) { + PUSHs(&PL_sv_undef); + } } else if (argc > 0) { - va_list args; - va_start(args, argc); + va_list args; + va_start(args, argc); - do { - SV *const this_sv = va_arg(args, SV *); - PUSHs(this_sv); - } while (--argc); + do { + SV *const this_sv = va_arg(args, SV *); + PUSHs(this_sv); + } while (--argc); - va_end(args); + va_end(args); } PUTBACK; if (flags & G_DISCARD) { - call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED); + call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED); } else { - if (call_sv(meth, G_SCALAR|G_METHOD_NAMED)) - ret = *PL_stack_sp--; + if (call_sv(meth, G_SCALAR|G_METHOD_NAMED)) + ret = *PL_stack_sp--; } POPSTACK; if (flags & G_WRITING_TO_STDERR) - FREETMPS; + FREETMPS; LEAVE; return ret; } @@ -1994,18 +1994,18 @@ S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, PERL_ARGS_ASSERT_MAGIC_METHCALL1; if (mg->mg_ptr) { - if (mg->mg_len >= 0) { - arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); - } - else if (mg->mg_len == HEf_SVKEY) - arg1 = MUTABLE_SV(mg->mg_ptr); + if (mg->mg_len >= 0) { + arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); + } + else if (mg->mg_len == HEf_SVKEY) + arg1 = MUTABLE_SV(mg->mg_ptr); } else if (mg->mg_type == PERL_MAGIC_tiedelem) { - arg1 = newSViv((IV)(mg->mg_len)); - sv_2mortal(arg1); + arg1 = newSViv((IV)(mg->mg_len)); + sv_2mortal(arg1); } if (!arg1) { - return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val); + return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val); } return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val); } @@ -2019,7 +2019,7 @@ S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth) ret = magic_methcall1(sv, mg, meth, 0, 1, NULL); if (ret) - sv_setsv(sv, ret); + sv_setsv(sv, ret); return 0; } @@ -2029,7 +2029,7 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETPACK; if (mg->mg_type == PERL_MAGIC_tiedelem) - mg->mg_flags |= MGf_GSKIP; + mg->mg_flags |= MGf_GSKIP; magic_methpack(sv,mg,SV_CONST(FETCH)); return 0; } @@ -2053,13 +2053,13 @@ Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) * re-enabling magic on sv). */ if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint)) - && (tmg->mg_len & 1)) + && (tmg->mg_len & 1)) { - val = sv_mortalcopy(sv); - SvTAINTED_on(val); + val = sv_mortalcopy(sv); + SvTAINTED_on(val); } else - val = sv; + val = sv; magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val); return 0; @@ -2085,9 +2085,9 @@ Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL); if (retsv) { - retval = SvIV(retsv)-1; - if (retval < -1) - Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); + retval = SvIV(retsv)-1; + if (retval < -1) + Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); } return (U32) retval; } @@ -2109,9 +2109,9 @@ Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) PERL_ARGS_ASSERT_MAGIC_NEXTPACK; ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key) - : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0); + : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0); if (ret) - sv_setsv(key,ret); + sv_setsv(key,ret); return 0; } @@ -2147,7 +2147,7 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) /* there is a SCALAR method that we can call */ retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0); if (!retval) - retval = &PL_sv_undef; + retval = &PL_sv_undef; return retval; } @@ -2167,23 +2167,23 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) /* Use sv_2iv instead of SvIV() as the former generates smaller code, and setting/clearing debugger breakpoints is not a hot path. */ svp = av_fetch(MUTABLE_AV(mg->mg_obj), - sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE); + sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE); if (svp && SvIOKp(*svp)) { - OP * const o = INT2PTR(OP*,SvIVX(*svp)); - if (o) { + OP * const o = INT2PTR(OP*,SvIVX(*svp)); + if (o) { #ifdef PERL_DEBUG_READONLY_OPS - Slab_to_rw(OpSLAB(o)); + Slab_to_rw(OpSLAB(o)); #endif - /* set or clear breakpoint in the relevant control op */ - if (SvTRUE(sv)) - o->op_flags |= OPf_SPECIAL; - else - o->op_flags &= ~OPf_SPECIAL; + /* set or clear breakpoint in the relevant control op */ + if (SvTRUE(sv)) + o->op_flags |= OPf_SPECIAL; + else + o->op_flags &= ~OPf_SPECIAL; #ifdef PERL_DEBUG_READONLY_OPS - Slab_to_ro(OpSLAB(o)); + Slab_to_ro(OpSLAB(o)); #endif - } + } } return 0; } @@ -2196,7 +2196,7 @@ Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETARYLEN; if (obj) { - sv_setiv(sv, AvFILL(obj)); + sv_setiv(sv, AvFILL(obj)); } else { sv_set_undef(sv); } @@ -2211,10 +2211,10 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETARYLEN; if (obj) { - av_fill(obj, SvIV(sv)); + av_fill(obj, SvIV(sv)); } else { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), - "Attempt to set length of freed array"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Attempt to set length of freed array"); } return 0; } @@ -2228,10 +2228,10 @@ Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) /* Reset the iterator when the array is cleared */ if (sizeof(IV) == sizeof(SSize_t)) { - *((IV *) &(mg->mg_len)) = 0; + *((IV *) &(mg->mg_len)) = 0; } else { - if (mg->mg_ptr) - *((IV *) mg->mg_ptr) = 0; + if (mg->mg_ptr) + *((IV *) mg->mg_ptr) = 0; } return 0; @@ -2245,17 +2245,17 @@ Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) /* during global destruction, mg_obj may already have been freed */ if (PL_in_clean_all) - return 0; + return 0; mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen); if (mg) { - /* arylen scalar holds a pointer back to the array, but doesn't own a - reference. Hence the we (the array) are about to go away with it - still pointing at us. Clear its pointer, else it would be pointing - at free memory. See the comment in sv_magic about reference loops, - and why it can't own a reference to us. */ - mg->mg_obj = 0; + /* arylen scalar holds a pointer back to the array, but doesn't own a + reference. Hence the we (the array) are about to go away with it + still pointing at us. Clear its pointer, else it would be pointing + at free memory. See the comment in sv_magic about reference loops, + and why it can't own a reference to us. */ + mg->mg_obj = 0; } return 0; } @@ -2270,11 +2270,11 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(mg); if (found && found->mg_len != -1) { - STRLEN i = found->mg_len; - if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv)) - i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN); - sv_setuv(sv, i); - return 0; + STRLEN i = found->mg_len; + if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv)) + i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN); + sv_setuv(sv, i); + return 0; } sv_set_undef(sv); return 0; @@ -2294,13 +2294,13 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) found = mg_find_mglob(lsv); if (!found) { - if (!SvOK(sv)) - return 0; - found = sv_magicext_mglob(lsv); + if (!SvOK(sv)) + return 0; + found = sv_magicext_mglob(lsv); } else if (!SvOK(sv)) { - found->mg_len = -1; - return 0; + found->mg_len = -1; + return 0; } s = SvPV_const(lsv, len); @@ -2308,17 +2308,17 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) if (DO_UTF8(lsv)) { const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len); - if (ulen) - len = ulen; + if (ulen) + len = ulen; } if (pos < 0) { - pos += len; - if (pos < 0) - pos = 0; + pos += len; + if (pos < 0) + pos = 0; } else if (pos > (SSize_t)len) - pos = len; + pos = len; found->mg_len = pos; found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES); @@ -2341,17 +2341,17 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(mg); if (!translate_substr_offsets( - SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len, - negoff ? -(IV)offs : (IV)offs, !negoff, - negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem + SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len, + negoff ? -(IV)offs : (IV)offs, !negoff, + negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem )) { - Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); sv_set_undef(sv); - return 0; + return 0; } if (SvUTF8(lsv)) - offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem); + offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem); sv_setpvn(sv, tmps + offs, rem); if (SvUTF8(lsv)) SvUTF8_on(sv); @@ -2374,36 +2374,36 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) SvGETMAGIC(lsv); if (SvROK(lsv)) - Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), - "Attempt to use reference as lvalue in substr" - ); + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), + "Attempt to use reference as lvalue in substr" + ); SvPV_force_nomg(lsv,lsv_len); if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv); if (!translate_substr_offsets( - lsv_len, - negoff ? -(IV)lvoff : (IV)lvoff, !negoff, - neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen + lsv_len, + negoff ? -(IV)lvoff : (IV)lvoff, !negoff, + neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen )) - Perl_croak(aTHX_ "substr outside of string"); + Perl_croak(aTHX_ "substr outside of string"); oldtarglen = lvlen; if (DO_UTF8(sv)) { - sv_utf8_upgrade_nomg(lsv); - lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); - sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); - newtarglen = sv_or_pv_len_utf8(sv, tmps, len); - SvUTF8_on(lsv); + sv_utf8_upgrade_nomg(lsv); + lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); + sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); + newtarglen = sv_or_pv_len_utf8(sv, tmps, len); + SvUTF8_on(lsv); } else if (SvUTF8(lsv)) { - const char *utf8; - lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); - newtarglen = len; - utf8 = (char*)bytes_to_utf8((U8*)tmps, &len); - sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0); - Safefree(utf8); + const char *utf8; + lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); + newtarglen = len; + utf8 = (char*)bytes_to_utf8((U8*)tmps, &len); + sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0); + Safefree(utf8); } else { - sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); - newtarglen = len; + sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); + newtarglen = len; } if (!neglen) LvTARGLEN(sv) = newtarglen; if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen; @@ -2432,9 +2432,9 @@ Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) /* update taint status */ if (TAINT_get) - mg->mg_len |= 1; + mg->mg_len |= 1; else - mg->mg_len &= ~1; + mg->mg_len &= ~1; return 0; } @@ -2471,37 +2471,37 @@ Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg) if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem); assert(mg); if (LvTARGLEN(sv)) { - if (mg->mg_obj) { - SV * const ahv = LvTARG(sv); - HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0); + if (mg->mg_obj) { + SV * const ahv = LvTARG(sv); + HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0); if (he) targ = HeVAL(he); - } - else if (LvSTARGOFF(sv) >= 0) { - AV *const av = MUTABLE_AV(LvTARG(sv)); - if (LvSTARGOFF(sv) <= AvFILL(av)) - { - if (SvRMAGICAL(av)) { - SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0); - targ = svp ? *svp : NULL; - } - else - targ = AvARRAY(av)[LvSTARGOFF(sv)]; - } - } - if (targ && (targ != &PL_sv_undef)) { - /* somebody else defined it for us */ - SvREFCNT_dec(LvTARG(sv)); - LvTARG(sv) = SvREFCNT_inc_simple_NN(targ); - LvTARGLEN(sv) = 0; - SvREFCNT_dec(mg->mg_obj); - mg->mg_obj = NULL; - mg->mg_flags &= ~MGf_REFCOUNTED; - } - return targ; + } + else if (LvSTARGOFF(sv) >= 0) { + AV *const av = MUTABLE_AV(LvTARG(sv)); + if (LvSTARGOFF(sv) <= AvFILL(av)) + { + if (SvRMAGICAL(av)) { + SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0); + targ = svp ? *svp : NULL; + } + else + targ = AvARRAY(av)[LvSTARGOFF(sv)]; + } + } + if (targ && (targ != &PL_sv_undef)) { + /* somebody else defined it for us */ + SvREFCNT_dec(LvTARG(sv)); + LvTARG(sv) = SvREFCNT_inc_simple_NN(targ); + LvTARGLEN(sv) = 0; + SvREFCNT_dec(mg->mg_obj); + mg->mg_obj = NULL; + mg->mg_flags &= ~MGf_REFCOUNTED; + } + return targ; } else - return LvTARG(sv); + return LvTARG(sv); } int @@ -2519,10 +2519,10 @@ Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETDEFELEM; PERL_UNUSED_ARG(mg); if (LvTARGLEN(sv)) - vivify_defelem(sv); + vivify_defelem(sv); if (LvTARG(sv)) { - sv_setsv(LvTARG(sv), sv); - SvSETMAGIC(LvTARG(sv)); + sv_setsv(LvTARG(sv), sv); + SvSETMAGIC(LvTARG(sv)); } return 0; } @@ -2536,26 +2536,26 @@ Perl_vivify_defelem(pTHX_ SV *sv) PERL_ARGS_ASSERT_VIVIFY_DEFELEM; if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem))) - return; + return; if (mg->mg_obj) { - SV * const ahv = LvTARG(sv); - HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0); + SV * const ahv = LvTARG(sv); + HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0); if (he) value = HeVAL(he); - if (!value || value == &PL_sv_undef) - Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj)); + if (!value || value == &PL_sv_undef) + Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj)); } else if (LvSTARGOFF(sv) < 0) - Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); + Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); else { - AV *const av = MUTABLE_AV(LvTARG(sv)); - if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av)) - LvTARG(sv) = NULL; /* array can't be extended */ - else { - SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE); - if (!svp || !(value = *svp)) - Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); - } + AV *const av = MUTABLE_AV(LvTARG(sv)); + if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av)) + LvTARG(sv) = NULL; /* array can't be extended */ + else { + SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE); + if (!svp || !(value = *svp)) + Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); + } } SvREFCNT_inc_simple_void(value); SvREFCNT_dec(LvTARG(sv)); @@ -2618,7 +2618,7 @@ Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETUVAR; if (uf && uf->uf_set) - (*uf->uf_set)(aTHX_ uf->uf_index, sv); + (*uf->uf_set)(aTHX_ uf->uf_index, sv); return 0; } @@ -2648,9 +2648,9 @@ Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(sv); if (mg->mg_ptr) { - Safefree(mg->mg_ptr); - mg->mg_ptr = NULL; - mg->mg_len = -1; + Safefree(mg->mg_ptr); + mg->mg_ptr = NULL; + mg->mg_len = -1; } return 0; } @@ -2711,52 +2711,52 @@ Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg) if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference"); switch (mg->mg_private & OPpLVREF_TYPE) { case OPpLVREF_SV: - if (SvTYPE(SvRV(sv)) > SVt_PVLV) - bad = " SCALAR"; - break; + if (SvTYPE(SvRV(sv)) > SVt_PVLV) + bad = " SCALAR"; + break; case OPpLVREF_AV: - if (SvTYPE(SvRV(sv)) != SVt_PVAV) - bad = "n ARRAY"; - break; + if (SvTYPE(SvRV(sv)) != SVt_PVAV) + bad = "n ARRAY"; + break; case OPpLVREF_HV: - if (SvTYPE(SvRV(sv)) != SVt_PVHV) - bad = " HASH"; - break; + if (SvTYPE(SvRV(sv)) != SVt_PVHV) + bad = " HASH"; + break; case OPpLVREF_CV: - if (SvTYPE(SvRV(sv)) != SVt_PVCV) - bad = " CODE"; + if (SvTYPE(SvRV(sv)) != SVt_PVCV) + bad = " CODE"; } if (bad) - /* diag_listed_as: Assigned value is not %s reference */ - Perl_croak(aTHX_ "Assigned value is not a%s reference", bad); + /* diag_listed_as: Assigned value is not %s reference */ + Perl_croak(aTHX_ "Assigned value is not a%s reference", bad); switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) { case 0: { - SV * const old = PAD_SV(mg->mg_len); - PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv))); - SvREFCNT_dec(old); - break; + SV * const old = PAD_SV(mg->mg_len); + PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv))); + SvREFCNT_dec(old); + break; } case SVt_PVGV: - gv_setref(mg->mg_obj, sv); - SvSETMAGIC(mg->mg_obj); - break; + gv_setref(mg->mg_obj, sv); + SvSETMAGIC(mg->mg_obj); + break; case SVt_PVAV: - av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr), - SvREFCNT_inc_simple_NN(SvRV(sv))); - break; + av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr), + SvREFCNT_inc_simple_NN(SvRV(sv))); + break; case SVt_PVHV: - (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr, + (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr, SvREFCNT_inc_simple_NN(SvRV(sv)), 0); } if (mg->mg_flags & MGf_PERSIST) - NOOP; /* This sv is in use as an iterator var and will be reused, - so we must leave the magic. */ + NOOP; /* This sv is in use as an iterator var and will be reused, + so we must leave the magic. */ else - /* This sv could be returned by the assignment op, so clear the - magic, as lvrefs are an implementation detail that must not be - leaked to the user. */ - sv_unmagic(sv, PERL_MAGIC_lvref); + /* This sv could be returned by the assignment op, so clear the + magic, as lvrefs are an implementation detail that must not be + leaked to the user. */ + sv_unmagic(sv, PERL_MAGIC_lvref); return 0; } @@ -2850,10 +2850,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (!mg->mg_ptr) { paren = mg->mg_len; - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { setparen_got_rx: CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv); - } else { + } else { /* Croak with a READONLY error when a numbered match var is * set without a previous pattern match. Unless it's C<local $1> */ @@ -2867,28 +2867,28 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) switch (*mg->mg_ptr) { case '\001': /* ^A */ - if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); - else SvOK_off(PL_bodytarget); - FmLINES(PL_bodytarget) = 0; - if (SvPOK(PL_bodytarget)) { - char *s = SvPVX(PL_bodytarget); + if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); + else SvOK_off(PL_bodytarget); + FmLINES(PL_bodytarget) = 0; + if (SvPOK(PL_bodytarget)) { + char *s = SvPVX(PL_bodytarget); char *e = SvEND(PL_bodytarget); - while ( ((s = (char *) memchr(s, '\n', e - s))) ) { - FmLINES(PL_bodytarget)++; - s++; - } - } - /* mg_set() has temporarily made sv non-magical */ - if (TAINTING_get) { - if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) - SvTAINTED_on(PL_bodytarget); - else - SvTAINTED_off(PL_bodytarget); - } - break; + while ( ((s = (char *) memchr(s, '\n', e - s))) ) { + FmLINES(PL_bodytarget)++; + s++; + } + } + /* mg_set() has temporarily made sv non-magical */ + if (TAINTING_get) { + if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) + SvTAINTED_on(PL_bodytarget); + else + SvTAINTED_off(PL_bodytarget); + } + break; case '\003': /* ^C */ - PL_minus_c = cBOOL(SvIV(sv)); - break; + PL_minus_c = cBOOL(SvIV(sv)); + break; case '\004': /* ^D */ #ifdef DEBUGGING @@ -2899,30 +2899,30 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) dump_all_perl(!DEBUG_B_TEST); } #else - PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG; + PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG; #endif - break; + break; case '\005': /* ^E */ - if (*(mg->mg_ptr+1) == '\0') { + if (*(mg->mg_ptr+1) == '\0') { #ifdef VMS - set_vaxc_errno(SvIV(sv)); + set_vaxc_errno(SvIV(sv)); #elif defined(WIN32) - SetLastError( SvIV(sv) ); + SetLastError( SvIV(sv) ); #elif defined(OS2) - os2_setsyserrno(SvIV(sv)); + os2_setsyserrno(SvIV(sv)); #else - /* will anyone ever use this? */ - SETERRNO(SvIV(sv), 4); + /* will anyone ever use this? */ + SETERRNO(SvIV(sv), 4); #endif - } - else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv)) + } + else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv)) Perl_croak(aTHX_ "${^ENCODING} is no longer supported"); - break; + break; case '\006': /* ^F */ if (mg->mg_ptr[1] == '\0') { PL_maxsysfd = SvIV(sv); } - break; + break; case '\010': /* ^H */ { U32 save_hints = PL_hints; @@ -2933,48 +2933,48 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) notify_parser_that_changed_to_utf8(); } } - break; + break; case '\011': /* ^I */ /* NOT \t in EBCDIC */ - Safefree(PL_inplace); - PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL; - break; + Safefree(PL_inplace); + PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL; + break; case '\016': /* ^N */ - if (PL_curpm && (rx = PM_GETRE(PL_curpm)) - && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx; - goto croakparen; + if (PL_curpm && (rx = PM_GETRE(PL_curpm)) + && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx; + goto croakparen; case '\017': /* ^O */ - if (*(mg->mg_ptr+1) == '\0') { - Safefree(PL_osname); - PL_osname = NULL; - if (SvOK(sv)) { - TAINT_PROPER("assigning to $^O"); - PL_osname = savesvpv(sv); - } - } - else if (strEQ(mg->mg_ptr, "\017PEN")) { - STRLEN len; - const char *const start = SvPV(sv, len); - const char *out = (const char*)memchr(start, '\0', len); - SV *tmp; - - - PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; - PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; - - /* Opening for input is more common than opening for output, so - ensure that hints for input are sooner on linked list. */ - tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, - SvUTF8(sv)) - : newSVpvs_flags("", SvUTF8(sv)); - (void)hv_stores(GvHV(PL_hintgv), "open>", tmp); - mg_set(tmp); - - tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len, - SvUTF8(sv)); - (void)hv_stores(GvHV(PL_hintgv), "open<", tmp); - mg_set(tmp); - } - break; + if (*(mg->mg_ptr+1) == '\0') { + Safefree(PL_osname); + PL_osname = NULL; + if (SvOK(sv)) { + TAINT_PROPER("assigning to $^O"); + PL_osname = savesvpv(sv); + } + } + else if (strEQ(mg->mg_ptr, "\017PEN")) { + STRLEN len; + const char *const start = SvPV(sv, len); + const char *out = (const char*)memchr(start, '\0', len); + SV *tmp; + + + PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; + PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; + + /* Opening for input is more common than opening for output, so + ensure that hints for input are sooner on linked list. */ + tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, + SvUTF8(sv)) + : newSVpvs_flags("", SvUTF8(sv)); + (void)hv_stores(GvHV(PL_hintgv), "open>", tmp); + mg_set(tmp); + + tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len, + SvUTF8(sv)); + (void)hv_stores(GvHV(PL_hintgv), "open<", tmp); + mg_set(tmp); + } + break; case '\020': /* ^P */ PL_perldb = SvIV(sv); if (PL_perldb && !PL_DBsingle) @@ -2982,106 +2982,106 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\024': /* ^T */ #ifdef BIG_TIME - PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); + PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); #else - PL_basetime = (Time_t)SvIV(sv); + PL_basetime = (Time_t)SvIV(sv); #endif - break; + break; case '\025': /* ^UTF8CACHE */ - if (strEQ(mg->mg_ptr+1, "TF8CACHE")) { - PL_utf8cache = (signed char) sv_2iv(sv); - } - break; + if (strEQ(mg->mg_ptr+1, "TF8CACHE")) { + PL_utf8cache = (signed char) sv_2iv(sv); + } + break; case '\027': /* ^W & $^WARNING_BITS */ - if (*(mg->mg_ptr+1) == '\0') { - if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { - i = SvIV(sv); - PL_dowarn = (PL_dowarn & ~G_WARN_ON) - | (i ? G_WARN_ON : G_WARN_OFF) ; - } - } - else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { - if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { - if (!SvPOK(sv)) { + if (*(mg->mg_ptr+1) == '\0') { + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { + i = SvIV(sv); + PL_dowarn = (PL_dowarn & ~G_WARN_ON) + | (i ? G_WARN_ON : G_WARN_OFF) ; + } + } + else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { + if (!SvPOK(sv)) { free_and_set_cop_warnings(&PL_compiling, pWARN_STD); - break; - } - { - STRLEN len, i; - int not_none = 0, not_all = 0; - const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ; - for (i = 0 ; i < len ; ++i) { - not_none |= ptr[i]; - not_all |= ptr[i] ^ 0x55; - } - if (!not_none) { + break; + } + { + STRLEN len, i; + int not_none = 0, not_all = 0; + const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ; + for (i = 0 ; i < len ; ++i) { + not_none |= ptr[i]; + not_all |= ptr[i] ^ 0x55; + } + if (!not_none) { free_and_set_cop_warnings(&PL_compiling, pWARN_NONE); - } else if (len >= WARNsize && !not_all) { + } else if (len >= WARNsize && !not_all) { free_and_set_cop_warnings(&PL_compiling, pWARN_ALL); - PL_dowarn |= G_WARN_ONCE ; - } + PL_dowarn |= G_WARN_ONCE ; + } else { - STRLEN len; - const char *const p = SvPV_const(sv, len); + STRLEN len; + const char *const p = SvPV_const(sv, len); - PL_compiling.cop_warnings - = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings, - p, len); + PL_compiling.cop_warnings + = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings, + p, len); - if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) - PL_dowarn |= G_WARN_ONCE ; - } + if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) + PL_dowarn |= G_WARN_ONCE ; + } - } - } - } - break; + } + } + } + break; case '.': - if (PL_localizing) { - if (PL_localizing == 1) - SAVESPTR(PL_last_in_gv); - } - else if (SvOK(sv) && GvIO(PL_last_in_gv)) - IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); - break; + if (PL_localizing) { + if (PL_localizing == 1) + SAVESPTR(PL_last_in_gv); + } + else if (SvOK(sv) && GvIO(PL_last_in_gv)) + IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); + break; case '^': - Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); - IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); - IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); - break; + Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); + IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); + IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); + break; case '~': - Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); - IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); - IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); - break; + Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); + IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); + IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); + break; case '=': - IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); - break; + IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); + break; case '-': - IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); - if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) - IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; - break; + IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); + if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) + IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; + break; case '%': - IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); - break; + IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); + break; case '|': - { - IO * const io = GvIO(PL_defoutgv); - if(!io) - break; - if ((SvIV(sv)) == 0) - IoFLAGS(io) &= ~IOf_FLUSH; - else { - if (!(IoFLAGS(io) & IOf_FLUSH)) { - PerlIO *ofp = IoOFP(io); - if (ofp) - (void)PerlIO_flush(ofp); - IoFLAGS(io) |= IOf_FLUSH; - } - } - } - break; + { + IO * const io = GvIO(PL_defoutgv); + if(!io) + break; + if ((SvIV(sv)) == 0) + IoFLAGS(io) &= ~IOf_FLUSH; + else { + if (!(IoFLAGS(io) & IOf_FLUSH)) { + PerlIO *ofp = IoOFP(io); + if (ofp) + (void)PerlIO_flush(ofp); + IoFLAGS(io) |= IOf_FLUSH; + } + } + } + break; case '/': { if (SvROK(sv)) { @@ -3111,36 +3111,36 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) SvREFCNT_dec(PL_rs); PL_rs = newSVsv(sv); } - break; + break; case '\\': - SvREFCNT_dec(PL_ors_sv); - if (SvOK(sv)) { - PL_ors_sv = newSVsv(sv); - } - else { - PL_ors_sv = NULL; - } - break; + SvREFCNT_dec(PL_ors_sv); + if (SvOK(sv)) { + PL_ors_sv = newSVsv(sv); + } + else { + PL_ors_sv = NULL; + } + break; case '[': - if (SvIV(sv) != 0) - Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible"); - break; + if (SvIV(sv) != 0) + Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible"); + break; case '?': #ifdef COMPLEX_STATUS - if (PL_localizing == 2) { - SvUPGRADE(sv, SVt_PVLV); - PL_statusvalue = LvTARGOFF(sv); - PL_statusvalue_vms = LvTARGLEN(sv); - } - else + if (PL_localizing == 2) { + SvUPGRADE(sv, SVt_PVLV); + PL_statusvalue = LvTARGOFF(sv); + PL_statusvalue_vms = LvTARGLEN(sv); + } + else #endif #ifdef VMSISH_STATUS - if (VMSISH_STATUS) - STATUS_NATIVE_CHILD_SET((U32)SvIV(sv)); - else + if (VMSISH_STATUS) + STATUS_NATIVE_CHILD_SET((U32)SvIV(sv)); + else #endif - STATUS_UNIX_EXIT_SET(SvIV(sv)); - break; + STATUS_UNIX_EXIT_SET(SvIV(sv)); + break; case '!': { #ifdef VMS @@ -3149,93 +3149,93 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) # define PERL_VMS_BANG 0 #endif #if defined(WIN32) - SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0), - (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); + SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0), + (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); #else - SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, - (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); + SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, + (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); #endif - } - break; + } + break; case '<': - { + { /* XXX $< currently silently ignores failures */ - const Uid_t new_uid = SvUID(sv); - PL_delaymagic_uid = new_uid; - if (PL_delaymagic) { - PL_delaymagic |= DM_RUID; - break; /* don't do magic till later */ - } + const Uid_t new_uid = SvUID(sv); + PL_delaymagic_uid = new_uid; + if (PL_delaymagic) { + PL_delaymagic |= DM_RUID; + break; /* don't do magic till later */ + } #ifdef HAS_SETRUID - PERL_UNUSED_RESULT(setruid(new_uid)); + PERL_UNUSED_RESULT(setruid(new_uid)); #elif defined(HAS_SETREUID) PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1)); #elif defined(HAS_SETRESUID) PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1)); #else - if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ + if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ # ifdef PERL_DARWIN - /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ - if (new_uid != 0 && PerlProc_getuid() == 0) + /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ + if (new_uid != 0 && PerlProc_getuid() == 0) PERL_UNUSED_RESULT(PerlProc_setuid(0)); # endif PERL_UNUSED_RESULT(PerlProc_setuid(new_uid)); - } else { - Perl_croak(aTHX_ "setruid() not implemented"); - } + } else { + Perl_croak(aTHX_ "setruid() not implemented"); + } #endif - break; - } + break; + } case '>': - { + { /* XXX $> currently silently ignores failures */ - const Uid_t new_euid = SvUID(sv); - PL_delaymagic_euid = new_euid; - if (PL_delaymagic) { - PL_delaymagic |= DM_EUID; - break; /* don't do magic till later */ - } + const Uid_t new_euid = SvUID(sv); + PL_delaymagic_euid = new_euid; + if (PL_delaymagic) { + PL_delaymagic |= DM_EUID; + break; /* don't do magic till later */ + } #ifdef HAS_SETEUID - PERL_UNUSED_RESULT(seteuid(new_euid)); + PERL_UNUSED_RESULT(seteuid(new_euid)); #elif defined(HAS_SETREUID) - PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid)); + PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid)); #elif defined(HAS_SETRESUID) - PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1)); + PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1)); #else - if (new_euid == PerlProc_getuid()) /* special case $> = $< */ - PERL_UNUSED_RESULT(PerlProc_setuid(new_euid)); - else { - Perl_croak(aTHX_ "seteuid() not implemented"); - } -#endif - break; - } + if (new_euid == PerlProc_getuid()) /* special case $> = $< */ + PERL_UNUSED_RESULT(PerlProc_setuid(new_euid)); + else { + Perl_croak(aTHX_ "seteuid() not implemented"); + } +#endif + break; + } case '(': - { + { /* XXX $( currently silently ignores failures */ - const Gid_t new_gid = SvGID(sv); - PL_delaymagic_gid = new_gid; - if (PL_delaymagic) { - PL_delaymagic |= DM_RGID; - break; /* don't do magic till later */ - } + const Gid_t new_gid = SvGID(sv); + PL_delaymagic_gid = new_gid; + if (PL_delaymagic) { + PL_delaymagic |= DM_RGID; + break; /* don't do magic till later */ + } #ifdef HAS_SETRGID - PERL_UNUSED_RESULT(setrgid(new_gid)); + PERL_UNUSED_RESULT(setrgid(new_gid)); #elif defined(HAS_SETREGID) - PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1)); + PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1)); #elif defined(HAS_SETRESGID) PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1)); #else - if (new_gid == PerlProc_getegid()) /* special case $( = $) */ - PERL_UNUSED_RESULT(PerlProc_setgid(new_gid)); - else { - Perl_croak(aTHX_ "setrgid() not implemented"); - } -#endif - break; - } + if (new_gid == PerlProc_getegid()) /* special case $( = $) */ + PERL_UNUSED_RESULT(PerlProc_setgid(new_gid)); + else { + Perl_croak(aTHX_ "setrgid() not implemented"); + } +#endif + break; + } case ')': - { + { /* (hv) best guess: maybe we'll need configure probes to do a better job, * but you can override it if you need to. */ @@ -3243,10 +3243,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #define INVALID_GID ((Gid_t)-1) #endif /* XXX $) currently silently ignores failures */ - Gid_t new_egid; + Gid_t new_egid; #ifdef HAS_SETGROUPS - { - const char *p = SvPV_const(sv, len); + { + const char *p = SvPV_const(sv, len); Groups_t *gary = NULL; const char* p_end = p + len; const char* endptr = p_end; @@ -3290,50 +3290,50 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } if (i) PERL_UNUSED_RESULT(setgroups(i, gary)); - Safefree(gary); - } + Safefree(gary); + } #else /* HAS_SETGROUPS */ new_egid = SvGID(sv); #endif /* HAS_SETGROUPS */ - PL_delaymagic_egid = new_egid; - if (PL_delaymagic) { - PL_delaymagic |= DM_EGID; - break; /* don't do magic till later */ - } + PL_delaymagic_egid = new_egid; + if (PL_delaymagic) { + PL_delaymagic |= DM_EGID; + break; /* don't do magic till later */ + } #ifdef HAS_SETEGID - PERL_UNUSED_RESULT(setegid(new_egid)); + PERL_UNUSED_RESULT(setegid(new_egid)); #elif defined(HAS_SETREGID) - PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid)); + PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid)); #elif defined(HAS_SETRESGID) - PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1)); + PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1)); #else - if (new_egid == PerlProc_getgid()) /* special case $) = $( */ - PERL_UNUSED_RESULT(PerlProc_setgid(new_egid)); - else { - Perl_croak(aTHX_ "setegid() not implemented"); - } -#endif - break; - } + if (new_egid == PerlProc_getgid()) /* special case $) = $( */ + PERL_UNUSED_RESULT(PerlProc_setgid(new_egid)); + else { + Perl_croak(aTHX_ "setegid() not implemented"); + } +#endif + break; + } case ':': - PL_chopset = SvPV_force(sv,len); - break; + PL_chopset = SvPV_force(sv,len); + break; case '$': /* $$ */ - /* Store the pid in mg->mg_obj so we can tell when a fork has - occurred. mg->mg_obj points to *$ by default, so clear it. */ - if (isGV(mg->mg_obj)) { - if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */ - SvREFCNT_dec(mg->mg_obj); - mg->mg_flags |= MGf_REFCOUNTED; - mg->mg_obj = newSViv((IV)PerlProc_getpid()); - } - else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid()); - break; + /* Store the pid in mg->mg_obj so we can tell when a fork has + occurred. mg->mg_obj points to *$ by default, so clear it. */ + if (isGV(mg->mg_obj)) { + if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */ + SvREFCNT_dec(mg->mg_obj); + mg->mg_flags |= MGf_REFCOUNTED; + mg->mg_obj = newSViv((IV)PerlProc_getpid()); + } + else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid()); + break; case '0': - LOCK_DOLLARZERO_MUTEX; + LOCK_DOLLARZERO_MUTEX; S_set_dollarzero(aTHX_ sv); - UNLOCK_DOLLARZERO_MUTEX; - break; + UNLOCK_DOLLARZERO_MUTEX; + break; } return 0; } @@ -3389,15 +3389,15 @@ Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len) PERL_UNUSED_CONTEXT; for (sigv = (char* const*)PL_sig_name; *sigv; sigv++) - if (strlen(*sigv) == len && memEQ(sig,*sigv, len)) - return PL_sig_num[sigv - (char* const*)PL_sig_name]; + if (strlen(*sigv) == len && memEQ(sig,*sigv, len)) + return PL_sig_num[sigv - (char* const*)PL_sig_name]; #ifdef SIGCLD if (memEQs(sig, len, "CHLD")) - return SIGCLD; + return SIGCLD; #endif #ifdef SIGCHLD if (memEQs(sig, len, "CLD")) - return SIGCHLD; + return SIGCHLD; #endif return -1; } @@ -3477,54 +3477,54 @@ Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, if (!PL_psig_ptr[sig]) { - PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n", - PL_sig_name[sig]); - exit(sig); - } + PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n", + PL_sig_name[sig]); + exit(sig); + } if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { - /* Max number of items pushed there is 3*n or 4. We cannot fix - infinity, so we fix 4 (in fact 5): */ - if (PL_savestack_ix + 15 <= PL_savestack_max) { - flags |= 1; - PL_savestack_ix += 5; /* Protect save in progress. */ - SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL); - } + /* Max number of items pushed there is 3*n or 4. We cannot fix + infinity, so we fix 4 (in fact 5): */ + if (PL_savestack_ix + 15 <= PL_savestack_max) { + flags |= 1; + PL_savestack_ix += 5; /* Protect save in progress. */ + SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL); + } } /* sv_2cv is too complicated, try a simpler variant first: */ if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig]))) - || SvTYPE(cv) != SVt_PVCV) { - HV *st; - cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD); + || SvTYPE(cv) != SVt_PVCV) { + HV *st; + cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD); } if (!cv || !CvROOT(cv)) { - const HEK * const hek = gv - ? GvENAME_HEK(gv) - : cv && CvNAMED(cv) - ? CvNAME_HEK(cv) - : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL; - if (hek) - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), - "SIG%s handler \"%" HEKf "\" not defined.\n", - PL_sig_name[sig], HEKfARG(hek)); - /* diag_listed_as: SIG%s handler "%s" not defined */ - else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), - "SIG%s handler \"__ANON__\" not defined.\n", - PL_sig_name[sig]); - goto cleanup; + const HEK * const hek = gv + ? GvENAME_HEK(gv) + : cv && CvNAMED(cv) + ? CvNAME_HEK(cv) + : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL; + if (hek) + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "SIG%s handler \"%" HEKf "\" not defined.\n", + PL_sig_name[sig], HEKfARG(hek)); + /* diag_listed_as: SIG%s handler "%s" not defined */ + else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "SIG%s handler \"__ANON__\" not defined.\n", + PL_sig_name[sig]); + goto cleanup; } sv = PL_psig_name[sig] - ? SvREFCNT_inc_NN(PL_psig_name[sig]) - : newSVpv(PL_sig_name[sig],0); + ? SvREFCNT_inc_NN(PL_psig_name[sig]) + : newSVpv(PL_sig_name[sig],0); flags |= 8; SAVEFREESV(sv); if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { - /* make sure our assumption about the size of the SAVEs are correct: - * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */ - assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix); + /* make sure our assumption about the size of the SAVEs are correct: + * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */ + assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix); } PUSHSTACKi(PERLSI_SIGNAL); @@ -3533,9 +3533,9 @@ Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) { - struct sigaction oact; + struct sigaction oact; - if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) { + if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) { HV *sih = newHV(); SV *rv = newRV_noinc(MUTABLE_SV(sih)); /* The siginfo fields signo, code, errno, pid, uid, @@ -3568,7 +3568,7 @@ Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, PUSHs(rv); mPUSHp((char *)sip, sizeof(*sip)); - } + } } #endif @@ -3580,9 +3580,9 @@ Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, POPSTACK; { - SV * const errsv = ERRSV; - if (SvTRUE_NN(errsv)) { - SvREFCNT_dec(errsv_save); + SV * const errsv = ERRSV; + if (SvTRUE_NN(errsv)) { + SvREFCNT_dec(errsv_save); #ifndef PERL_MICRO /* Handler "died", for example to get out of a restart-able read(). @@ -3590,41 +3590,41 @@ Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL, * blocked by the system when we entered. */ # ifdef HAS_SIGPROCMASK - if (!safe) { + if (!safe) { /* safe signals called via dispatch_signals() set up a * savestack destructor, unblock_sigmask(), to * automatically unblock the handler at the end. If * instead we get here directly, we have to do it * ourselves */ - sigset_t set; - sigemptyset(&set); - sigaddset(&set,sig); - sigprocmask(SIG_UNBLOCK, &set, NULL); - } + sigset_t set; + sigemptyset(&set); + sigaddset(&set,sig); + sigprocmask(SIG_UNBLOCK, &set, NULL); + } # else - /* Not clear if this will work */ + /* Not clear if this will work */ /* XXX not clear if this should be protected by 'if (safe)' * too */ - (void)rsignal(sig, SIG_IGN); - (void)rsignal(sig, PL_csighandlerp); + (void)rsignal(sig, SIG_IGN); + (void)rsignal(sig, PL_csighandlerp); # endif #endif /* !PERL_MICRO */ - die_sv(errsv); - } - else { - sv_setsv(errsv, errsv_save); - SvREFCNT_dec(errsv_save); - } + die_sv(errsv); + } + else { + sv_setsv(errsv, errsv_save); + SvREFCNT_dec(errsv_save); + } } cleanup: /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */ PL_savestack_ix = old_ss_ix; if (flags & 8) - SvREFCNT_dec_NN(sv); + SvREFCNT_dec_NN(sv); PL_op = myop; /* Apparently not needed... */ PL_Sv = tSv; /* Restore global temporaries. */ @@ -3644,11 +3644,11 @@ S_restore_magic(pTHX_ const void *p) return; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */ - if (mgs->mgs_flags) - SvFLAGS(sv) |= mgs->mgs_flags; - else - mg_magical(sv); + SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */ + if (mgs->mgs_flags) + SvFLAGS(sv) |= mgs->mgs_flags; + else + mg_magical(sv); } bumped = mgs->mgs_bumped; @@ -3663,25 +3663,25 @@ S_restore_magic(pTHX_ const void *p) */ if (PL_savestack_ix == mgs->mgs_ss_ix) { - UV popval = SSPOPUV; + UV popval = SSPOPUV; assert(popval == SAVEt_DESTRUCTOR_X); PL_savestack_ix -= 2; - popval = SSPOPUV; + popval = SSPOPUV; assert((popval & SAVE_MASK) == SAVEt_ALLOC); PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT; } if (bumped) { - if (SvREFCNT(sv) == 1) { - /* We hold the last reference to this SV, which implies that the - SV was deleted as a side effect of the routines we called. - So artificially keep it alive a bit longer. - We avoid turning on the TEMP flag, which can cause the SV's - buffer to get stolen (and maybe other stuff). */ - sv_2mortal(sv); - SvTEMP_off(sv); - } - else - SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */ + if (SvREFCNT(sv) == 1) { + /* We hold the last reference to this SV, which implies that the + SV was deleted as a side effect of the routines we called. + So artificially keep it alive a bit longer. + We avoid turning on the TEMP flag, which can cause the SV's + buffer to get stolen (and maybe other stuff). */ + sv_2mortal(sv); + SvTEMP_off(sv); + } + else + SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */ } } @@ -3713,7 +3713,7 @@ int Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) { SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr) - : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); + : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); PERL_ARGS_ASSERT_MAGIC_SETHINT; @@ -3727,7 +3727,7 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) forgetting to do it, and consequent subtle errors. */ PL_hints |= HINT_LOCALIZE_HH; CopHINTHASH_set(&PL_compiling, - cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0)); + cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0)); magic_sethint_feature(key, NULL, 0, sv, 0); return 0; } @@ -3748,11 +3748,11 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) PL_hints |= HINT_LOCALIZE_HH; CopHINTHASH_set(&PL_compiling, - mg->mg_len == HEf_SVKEY - ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling), - MUTABLE_SV(mg->mg_ptr), 0, 0) - : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling), - mg->mg_ptr, mg->mg_len, 0, 0)); + mg->mg_len == HEf_SVKEY + ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling), + MUTABLE_SV(mg->mg_ptr), 0, 0) + : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling), + mg->mg_ptr, mg->mg_len, 0, 0)); if (mg->mg_len == HEf_SVKEY) magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE); else @@ -3781,7 +3781,7 @@ Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv, - const char *name, I32 namlen) + const char *name, I32 namlen) { MAGIC *nmg; @@ -15,7 +15,7 @@ struct mgvtbl { int (*svt_clear) (pTHX_ SV *sv, MAGIC* mg); int (*svt_free) (pTHX_ SV *sv, MAGIC* mg); int (*svt_copy) (pTHX_ SV *sv, MAGIC* mg, - SV *nsv, const char *name, I32 namlen); + SV *nsv, const char *name, I32 namlen); int (*svt_dup) (pTHX_ MAGIC *mg, CLONE_PARAMS *param); int (*svt_local)(pTHX_ SV *nsv, MAGIC *mg); }; @@ -47,14 +47,14 @@ struct magic { #define MgTAINTEDDIR_off(mg) (mg->mg_flags &= ~MGf_TAINTEDDIR) #define MgPV(mg,lp) ((((int)(lp = (mg)->mg_len)) == HEf_SVKEY) ? \ - SvPV(MUTABLE_SV((mg)->mg_ptr),lp) : \ - (mg)->mg_ptr) + SvPV(MUTABLE_SV((mg)->mg_ptr),lp) : \ + (mg)->mg_ptr) #define MgPV_const(mg,lp) ((((int)(lp = (mg)->mg_len)) == HEf_SVKEY) ? \ - SvPV_const(MUTABLE_SV((mg)->mg_ptr),lp) : \ - (const char*)(mg)->mg_ptr) + SvPV_const(MUTABLE_SV((mg)->mg_ptr),lp) : \ + (const char*)(mg)->mg_ptr) #define MgPV_nolen_const(mg) (((((int)(mg)->mg_len)) == HEf_SVKEY) ? \ - SvPV_nolen_const(MUTABLE_SV((mg)->mg_ptr)) : \ - (const char*)(mg)->mg_ptr) + SvPV_nolen_const(MUTABLE_SV((mg)->mg_ptr)) : \ + (const char*)(mg)->mg_ptr) #define SvTIED_mg(sv,how) (SvRMAGICAL(sv) ? mg_find((sv),(how)) : NULL) #define SvTIED_obj(sv,mg) \ @@ -66,11 +66,11 @@ struct magic { # define MgBYTEPOS_set(mg,sv,pv,off) ( \ assert_((mg)->mg_type == PERL_MAGIC_regex_global) \ SvPOK(sv) && (!SvGMAGICAL(sv) || sv_only_taint_gmagic(sv)) \ - ? (mg)->mg_len = (off), (mg)->mg_flags |= MGf_BYTES \ - : ((mg)->mg_len = DO_UTF8(sv) \ - ? (SSize_t)utf8_length((U8 *)(pv), (U8 *)(pv)+(off)) \ - : (SSize_t)(off), \ - (mg)->mg_flags &= ~MGf_BYTES)) + ? (mg)->mg_len = (off), (mg)->mg_flags |= MGf_BYTES \ + : ((mg)->mg_len = DO_UTF8(sv) \ + ? (SSize_t)utf8_length((U8 *)(pv), (U8 *)(pv)+(off)) \ + : (SSize_t)(off), \ + (mg)->mg_flags &= ~MGf_BYTES)) #endif #define whichsig(pv) whichsig_pv(pv) diff --git a/mro_core.c b/mro_core.c index 378c738c7a..25642d826f 100644 --- a/mro_core.c +++ b/mro_core.c @@ -35,68 +35,68 @@ static const struct mro_alg dfs_alg = SV * Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta, - const struct mro_alg *const which) + const struct mro_alg *const which) { SV **data; PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA; data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL, - which->name, which->length, which->kflags, - HV_FETCH_JUST_SV, NULL, which->hash); + which->name, which->length, which->kflags, + HV_FETCH_JUST_SV, NULL, which->hash); if (!data) - return NULL; + return NULL; /* If we've been asked to look up the private data for the current MRO, then cache it. */ if (smeta->mro_which == which) - smeta->mro_linear_current = *data; + smeta->mro_linear_current = *data; return *data; } SV * Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta, - const struct mro_alg *const which, SV *const data) + const struct mro_alg *const which, SV *const data) { PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA; if (!smeta->mro_linear_all) { - if (smeta->mro_which == which) { - /* If all we need to store is the current MRO's data, then don't use - memory on a hash with 1 element - store it direct, and signal - this by leaving the would-be-hash NULL. */ - smeta->mro_linear_current = data; - return data; - } else { - HV *const hv = newHV(); - /* Start with 2 buckets. It's unlikely we'll need more. */ - HvMAX(hv) = 1; - smeta->mro_linear_all = hv; - - if (smeta->mro_linear_current) { - /* If we were storing something directly, put it in the hash - before we lose it. */ - Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which, - smeta->mro_linear_current); - } - } + if (smeta->mro_which == which) { + /* If all we need to store is the current MRO's data, then don't use + memory on a hash with 1 element - store it direct, and signal + this by leaving the would-be-hash NULL. */ + smeta->mro_linear_current = data; + return data; + } else { + HV *const hv = newHV(); + /* Start with 2 buckets. It's unlikely we'll need more. */ + HvMAX(hv) = 1; + smeta->mro_linear_all = hv; + + if (smeta->mro_linear_current) { + /* If we were storing something directly, put it in the hash + before we lose it. */ + Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which, + smeta->mro_linear_current); + } + } } /* We get here if we're storing more than one linearisation for this stash, or the linearisation we are storing is not that if its current MRO. */ if (smeta->mro_which == which) { - /* If we've been asked to store the private data for the current MRO, - then cache it. */ - smeta->mro_linear_current = data; + /* If we've been asked to store the private data for the current MRO, + then cache it. */ + smeta->mro_linear_current = data; } if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL, - which->name, which->length, which->kflags, - HV_FETCH_ISSTORE, data, which->hash)) { - Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() " - "for '%.*s' %d", (int) which->length, which->name, - which->kflags); + which->name, which->length, which->kflags, + HV_FETCH_ISSTORE, data, which->hash)) { + Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() " + "for '%.*s' %d", (int) which->length, which->name, + which->kflags); } return data; @@ -109,9 +109,9 @@ Perl_mro_get_from_name(pTHX_ SV *name) { PERL_ARGS_ASSERT_MRO_GET_FROM_NAME; data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0, - HV_FETCH_JUST_SV, NULL, 0); + HV_FETCH_JUST_SV, NULL, 0); if (!data) - return NULL; + return NULL; assert(SvTYPE(*data) == SVt_IV); assert(SvIOK(*data)); return INT2PTR(const struct mro_alg *, SvUVX(*data)); @@ -133,11 +133,11 @@ Perl_mro_register(pTHX_ const struct mro_alg *mro) { if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL, - mro->name, mro->length, mro->kflags, - HV_FETCH_ISSTORE, wrapper, mro->hash)) { - SvREFCNT_dec_NN(wrapper); - Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() " - "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags); + mro->name, mro->length, mro->kflags, + HV_FETCH_ISSTORE, wrapper, mro->hash)) { + SvREFCNT_dec_NN(wrapper); + Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() " + "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags); } } @@ -173,23 +173,23 @@ Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) Copy(smeta, newmeta, 1, struct mro_meta); if (newmeta->mro_linear_all) { - newmeta->mro_linear_all - = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param)); - /* This is just acting as a shortcut pointer, and will be automatically - updated on the first get. */ - newmeta->mro_linear_current = NULL; + newmeta->mro_linear_all + = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param)); + /* This is just acting as a shortcut pointer, and will be automatically + updated on the first get. */ + newmeta->mro_linear_current = NULL; } else if (newmeta->mro_linear_current) { - /* Only the current MRO is stored, so this owns the data. */ - newmeta->mro_linear_current - = sv_dup_inc((const SV *)newmeta->mro_linear_current, param); + /* Only the current MRO is stored, so this owns the data. */ + newmeta->mro_linear_current + = sv_dup_inc((const SV *)newmeta->mro_linear_current, param); } if (newmeta->mro_nextmethod) - newmeta->mro_nextmethod - = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param)); + newmeta->mro_nextmethod + = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param)); if (newmeta->isa) - newmeta->isa - = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param)); + newmeta->isa + = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param)); newmeta->super = NULL; @@ -243,8 +243,8 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) if (level > 100) Perl_croak(aTHX_ - "Recursive inheritance detected in package '%" HEKf "'", - HEKfARG(stashhek)); + "Recursive inheritance detected in package '%" HEKf "'", + HEKfARG(stashhek)); meta = HvMROMETA(stash); @@ -280,85 +280,85 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) while (items--) { SV* const sv = *svp ? *svp : &PL_sv_undef; HV* const basestash = gv_stashsv(sv, 0); - SV *const *subrv_p; - I32 subrv_items; - svp++; + SV *const *subrv_p; + I32 subrv_items; + svp++; if (!basestash) { /* if no stash exists for this @ISA member, simply add it to the MRO and move on */ - subrv_p = &sv; - subrv_items = 1; + subrv_p = &sv; + subrv_items = 1; } else { /* otherwise, recurse into ourselves for the MRO of this @ISA member, and append their MRO to ours. - The recursive call could throw an exception, which - has memory management implications here, hence the use of - the mortal. */ - const AV *const subrv - = mro_get_linear_isa_dfs(basestash, level + 1); - - subrv_p = AvARRAY(subrv); - subrv_items = AvFILLp(subrv) + 1; - } - if (stored) { - while(subrv_items--) { - SV *const subsv = *subrv_p++; - /* LVALUE fetch will create a new undefined SV if necessary - */ - HE *const he = hv_fetch_ent(stored, subsv, 1, 0); - assert(he); - if(HeVAL(he) != &PL_sv_undef) { - /* It was newly created. Steal it for our new SV, and - replace it in the hash with the "real" thing. */ - SV *const val = HeVAL(he); - HEK *const key = HeKEY_hek(he); - - HeVAL(he) = &PL_sv_undef; - sv_sethek(val, key); - av_push(retval, val); - } - } + The recursive call could throw an exception, which + has memory management implications here, hence the use of + the mortal. */ + const AV *const subrv + = mro_get_linear_isa_dfs(basestash, level + 1); + + subrv_p = AvARRAY(subrv); + subrv_items = AvFILLp(subrv) + 1; + } + if (stored) { + while(subrv_items--) { + SV *const subsv = *subrv_p++; + /* LVALUE fetch will create a new undefined SV if necessary + */ + HE *const he = hv_fetch_ent(stored, subsv, 1, 0); + assert(he); + if(HeVAL(he) != &PL_sv_undef) { + /* It was newly created. Steal it for our new SV, and + replace it in the hash with the "real" thing. */ + SV *const val = HeVAL(he); + HEK *const key = HeKEY_hek(he); + + HeVAL(he) = &PL_sv_undef; + sv_sethek(val, key); + av_push(retval, val); + } + } } else { - /* We are the first (or only) parent. We can short cut the - complexity above, because our @ISA is simply us prepended - to our parent's @ISA, and our ->isa cache is simply our - parent's, with our name added. */ - /* newSVsv() is slow. This code is only faster if we can avoid - it by ensuring that SVs in the arrays are shared hash key - scalar SVs, because we can "copy" them very efficiently. - Although to be fair, we can't *ensure* this, as a reference - to the internal array is returned by mro::get_linear_isa(), - so we'll have to be defensive just in case someone faffed - with it. */ - if (basestash) { - SV **svp; - stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa))); - av_extend(retval, subrv_items); - AvFILLp(retval) = subrv_items; - svp = AvARRAY(retval); - while(subrv_items--) { - SV *const val = *subrv_p++; - *++svp = SvIsCOW_shared_hash(val) - ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val))) - : newSVsv(val); - } - } else { - /* They have no stash. So create ourselves an ->isa cache - as if we'd copied it from what theirs should be. */ - stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); - (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef); - av_push(retval, - newSVhek(HeKEY_hek(hv_store_ent(stored, sv, - &PL_sv_undef, 0)))); - } - } + /* We are the first (or only) parent. We can short cut the + complexity above, because our @ISA is simply us prepended + to our parent's @ISA, and our ->isa cache is simply our + parent's, with our name added. */ + /* newSVsv() is slow. This code is only faster if we can avoid + it by ensuring that SVs in the arrays are shared hash key + scalar SVs, because we can "copy" them very efficiently. + Although to be fair, we can't *ensure* this, as a reference + to the internal array is returned by mro::get_linear_isa(), + so we'll have to be defensive just in case someone faffed + with it. */ + if (basestash) { + SV **svp; + stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa))); + av_extend(retval, subrv_items); + AvFILLp(retval) = subrv_items; + svp = AvARRAY(retval); + while(subrv_items--) { + SV *const val = *subrv_p++; + *++svp = SvIsCOW_shared_hash(val) + ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val))) + : newSVsv(val); + } + } else { + /* They have no stash. So create ourselves an ->isa cache + as if we'd copied it from what theirs should be. */ + stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); + (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef); + av_push(retval, + newSVhek(HeKEY_hek(hv_store_ent(stored, sv, + &PL_sv_undef, 0)))); + } + } } } else { - /* We have no parents. */ - stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); - (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef); + /* We have no parents. */ + stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); + (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef); } (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0); @@ -380,7 +380,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) SvREADONLY_on(retval); return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg, - MUTABLE_SV(retval))); + MUTABLE_SV(retval))); } /* @@ -415,49 +415,49 @@ Perl_mro_get_linear_isa(pTHX_ HV *stash) isa = meta->mro_which->resolve(aTHX_ stash, 0); if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */ - SV * const namesv = - (HvENAME(stash)||HvNAME(stash)) - ? newSVhek(HvENAME_HEK(stash) - ? HvENAME_HEK(stash) - : HvNAME_HEK(stash)) - : NULL; - - if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv))) - { - AV * const old = isa; - SV **svp; - SV **ovp = AvARRAY(old); - SV * const * const oend = ovp + AvFILLp(old) + 1; - isa = (AV *)sv_2mortal((SV *)newAV()); - av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1); - *AvARRAY(isa) = namesv; - svp = AvARRAY(isa)+1; - while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++); - } - else SvREFCNT_dec(namesv); + SV * const namesv = + (HvENAME(stash)||HvNAME(stash)) + ? newSVhek(HvENAME_HEK(stash) + ? HvENAME_HEK(stash) + : HvNAME_HEK(stash)) + : NULL; + + if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv))) + { + AV * const old = isa; + SV **svp; + SV **ovp = AvARRAY(old); + SV * const * const oend = ovp + AvFILLp(old) + 1; + isa = (AV *)sv_2mortal((SV *)newAV()); + av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1); + *AvARRAY(isa) = namesv; + svp = AvARRAY(isa)+1; + while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++); + } + else SvREFCNT_dec(namesv); } if (!meta->isa) { - HV *const isa_hash = newHV(); - /* Linearisation didn't build it for us, so do it here. */ - SV *const *svp = AvARRAY(isa); - SV *const *const svp_end = svp + AvFILLp(isa) + 1; - const HEK *canon_name = HvENAME_HEK(stash); - if (!canon_name) canon_name = HvNAME_HEK(stash); - - while (svp < svp_end) { - (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0); - } - - (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name), - HEK_LEN(canon_name), HEK_FLAGS(canon_name), - HV_FETCH_ISSTORE, &PL_sv_undef, - HEK_HASH(canon_name)); - (void) hv_stores(isa_hash, "UNIVERSAL", &PL_sv_undef); - - SvREADONLY_on(isa_hash); - - meta->isa = isa_hash; + HV *const isa_hash = newHV(); + /* Linearisation didn't build it for us, so do it here. */ + SV *const *svp = AvARRAY(isa); + SV *const *const svp_end = svp + AvFILLp(isa) + 1; + const HEK *canon_name = HvENAME_HEK(stash); + if (!canon_name) canon_name = HvNAME_HEK(stash); + + while (svp < svp_end) { + (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0); + } + + (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name), + HEK_LEN(canon_name), HEK_FLAGS(canon_name), + HV_FETCH_ISSTORE, &PL_sv_undef, + HEK_HASH(canon_name)); + (void) hv_stores(isa_hash, "UNIVERSAL", &PL_sv_undef); + + SvREADONLY_on(isa_hash); + + meta->isa = isa_hash; } return isa; @@ -476,14 +476,14 @@ by the C<setisa> magic, should not need to invoke directly. /* Macro to avoid repeating the code five times. */ #define CLEAR_LINEAR(mEta) \ if (mEta->mro_linear_all) { \ - SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \ - mEta->mro_linear_all = NULL; \ - /* This is just acting as a shortcut pointer. */ \ - mEta->mro_linear_current = NULL; \ + SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \ + mEta->mro_linear_all = NULL; \ + /* This is just acting as a shortcut pointer. */ \ + mEta->mro_linear_current = NULL; \ } else if (mEta->mro_linear_current) { \ - /* Only the current MRO is stored, so this owns the data. */ \ - SvREFCNT_dec(mEta->mro_linear_current); \ - mEta->mro_linear_current = NULL; \ + /* Only the current MRO is stored, so this owns the data. */ \ + SvREFCNT_dec(mEta->mro_linear_current); \ + mEta->mro_linear_current = NULL; \ } void @@ -512,9 +512,9 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) meta = HvMROMETA(stash); CLEAR_LINEAR(meta); if (meta->isa) { - /* Steal it for our own purposes. */ - isa = (HV *)sv_2mortal((SV *)meta->isa); - meta->isa = NULL; + /* Steal it for our own purposes. */ + isa = (HV *)sv_2mortal((SV *)meta->isa); + meta->isa = NULL; } /* Inc the package generation, since our @ISA changed */ @@ -533,7 +533,7 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) } else { /* Wipe the local method cache otherwise */ meta->cache_gen++; - is_universal = FALSE; + is_universal = FALSE; } /* wipe next::method cache too */ @@ -573,19 +573,19 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) if(!revstash) continue; revmeta = HvMROMETA(revstash); - CLEAR_LINEAR(revmeta); + CLEAR_LINEAR(revmeta); if(!is_universal) revmeta->cache_gen++; if(revmeta->mro_nextmethod) hv_clear(revmeta->mro_nextmethod); - if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; - - (void) - hv_store( - isa_hashes, (const char*)&revstash, sizeof(HV *), - revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0 - ); - revmeta->isa = NULL; + if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL; + + (void) + hv_store( + isa_hashes, (const char*)&revstash, sizeof(HV *), + revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0 + ); + revmeta->isa = NULL; } /* Second pass: Update PL_isarev. We can just use isa_hashes to @@ -661,20 +661,20 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); - /* That fetch should not fail. But if it had to create a new SV for - us, then will need to upgrade it to an HV (which sv_upgrade() can - now do for us. */ + /* That fetch should not fail. But if it had to create a new SV for + us, then will need to upgrade it to an HV (which sv_upgrade() can + now do for us. */ mroisarev = MUTABLE_HV(HeVAL(he)); - SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); + SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); - /* This hash only ever contains PL_sv_yes. Storing it over itself is - almost as cheap as calling hv_exists, so on aggregate we expect to - save time by not making two calls to the common HV code for the - case where it doesn't exist. */ + /* This hash only ever contains PL_sv_yes. Storing it over itself is + almost as cheap as calling hv_exists, so on aggregate we expect to + save time by not making two calls to the common HV code for the + case where it doesn't exist. */ - (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes); + (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes); } /* Delete our name from our former parents' isarevs. */ @@ -771,12 +771,12 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, * If flags & 1, the caller has asked us to skip the check. */ if(!(flags & 1)) { - SV **svp; - if( - !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) || - !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) || - *svp != (SV *)gv - ) return; + SV **svp; + if( + !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) || + !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) || + *svp != (SV *)gv + ) return; } assert(SvOOK(GvSTASH(gv))); assert(GvNAMELEN(gv)); @@ -784,56 +784,56 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':'); name_count = HvAUX(GvSTASH(gv))->xhv_name_count; if (!name_count) { - name_count = 1; - namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name; + name_count = 1; + namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name; } else { - namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names; - if (name_count < 0) ++namep, name_count = -name_count - 1; + namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names; + if (name_count < 0) ++namep, name_count = -name_count - 1; } if (name_count == 1) { - if (memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")) { - namesv = GvNAMELEN(gv) == 1 - ? newSVpvs_flags(":", SVs_TEMP) - : newSVpvs_flags("", SVs_TEMP); - } - else { - namesv = sv_2mortal(newSVhek(*namep)); - if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":"); - else sv_catpvs(namesv, "::"); - } - if (GvNAMELEN(gv) != 1) { - sv_catpvn_flags( - namesv, GvNAME(gv), GvNAMELEN(gv) - 2, - /* skip trailing :: */ - GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES - ); + if (memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")) { + namesv = GvNAMELEN(gv) == 1 + ? newSVpvs_flags(":", SVs_TEMP) + : newSVpvs_flags("", SVs_TEMP); + } + else { + namesv = sv_2mortal(newSVhek(*namep)); + if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":"); + else sv_catpvs(namesv, "::"); + } + if (GvNAMELEN(gv) != 1) { + sv_catpvn_flags( + namesv, GvNAME(gv), GvNAMELEN(gv) - 2, + /* skip trailing :: */ + GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES + ); } } else { - SV *aname; - namesv = sv_2mortal((SV *)newAV()); - while (name_count--) { - if(memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")){ - aname = GvNAMELEN(gv) == 1 - ? newSVpvs(":") - : newSVpvs(""); - namep++; - } - else { - aname = newSVhek(*namep++); - if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":"); - else sv_catpvs(aname, "::"); - } - if (GvNAMELEN(gv) != 1) { - sv_catpvn_flags( - aname, GvNAME(gv), GvNAMELEN(gv) - 2, - /* skip trailing :: */ - GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES - ); + SV *aname; + namesv = sv_2mortal((SV *)newAV()); + while (name_count--) { + if(memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")){ + aname = GvNAMELEN(gv) == 1 + ? newSVpvs(":") + : newSVpvs(""); + namep++; } - av_push((AV *)namesv, aname); - } + else { + aname = newSVhek(*namep++); + if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":"); + else sv_catpvs(aname, "::"); + } + if (GvNAMELEN(gv) != 1) { + sv_catpvn_flags( + aname, GvNAME(gv), GvNAMELEN(gv) - 2, + /* skip trailing :: */ + GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES + ); + } + av_push((AV *)namesv, aname); + } } /* Get a list of all the affected classes. */ @@ -859,25 +859,25 @@ Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash, mro_isa_changed_in on each. */ hv_iterinit(stashes); while((iter = hv_iternext(stashes))) { - HV * const this_stash = *(HV **)HEK_KEY(HeKEY_hek(iter)); - if(HvENAME(this_stash)) { - /* We have to restore the original meta->isa (that - mro_gather_and_rename set aside for us) this way, in case - one class in this list is a superclass of a another class - that we have already encountered. In such a case, meta->isa - will have been overwritten without old entries being deleted - from PL_isarev. */ - struct mro_meta * const meta = HvMROMETA(this_stash); - if(meta->isa != (HV *)HeVAL(iter)){ - SvREFCNT_dec(meta->isa); - meta->isa - = HeVAL(iter) == &PL_sv_yes - ? NULL - : (HV *)HeVAL(iter); - HeVAL(iter) = NULL; /* We donated our reference count. */ - } - mro_isa_changed_in(this_stash); - } + HV * const this_stash = *(HV **)HEK_KEY(HeKEY_hek(iter)); + if(HvENAME(this_stash)) { + /* We have to restore the original meta->isa (that + mro_gather_and_rename set aside for us) this way, in case + one class in this list is a superclass of a another class + that we have already encountered. In such a case, meta->isa + will have been overwritten without old entries being deleted + from PL_isarev. */ + struct mro_meta * const meta = HvMROMETA(this_stash); + if(meta->isa != (HV *)HeVAL(iter)){ + SvREFCNT_dec(meta->isa); + meta->isa + = HeVAL(iter) == &PL_sv_yes + ? NULL + : (HV *)HeVAL(iter); + HeVAL(iter) = NULL; /* We donated our reference count. */ + } + mro_isa_changed_in(this_stash); + } } } @@ -915,196 +915,196 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, */ if(oldstash) { - /* Add to the big list. */ - struct mro_meta * meta; - HE * const entry - = (HE *) - hv_common( - seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0, - HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 - ); - if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) { - oldstash = NULL; - goto check_stash; - } - HeVAL(entry) - = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef; - meta = HvMROMETA(oldstash); - (void) - hv_store( - stashes, (const char *)&oldstash, sizeof(HV *), - meta->isa - ? SvREFCNT_inc_simple_NN((SV *)meta->isa) - : &PL_sv_yes, - 0 - ); - CLEAR_LINEAR(meta); - - /* Update the effective name. */ - if(HvENAME_get(oldstash)) { - const HEK * const enamehek = HvENAME_HEK(oldstash); - if(SvTYPE(namesv) == SVt_PVAV) { - items = AvFILLp((AV *)namesv) + 1; - svp = AvARRAY((AV *)namesv); - } - else { - items = 1; - svp = &namesv; - } - while (items--) { + /* Add to the big list. */ + struct mro_meta * meta; + HE * const entry + = (HE *) + hv_common( + seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0, + HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 + ); + if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) { + oldstash = NULL; + goto check_stash; + } + HeVAL(entry) + = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef; + meta = HvMROMETA(oldstash); + (void) + hv_store( + stashes, (const char *)&oldstash, sizeof(HV *), + meta->isa + ? SvREFCNT_inc_simple_NN((SV *)meta->isa) + : &PL_sv_yes, + 0 + ); + CLEAR_LINEAR(meta); + + /* Update the effective name. */ + if(HvENAME_get(oldstash)) { + const HEK * const enamehek = HvENAME_HEK(oldstash); + if(SvTYPE(namesv) == SVt_PVAV) { + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + } + else { + items = 1; + svp = &namesv; + } + while (items--) { const U32 name_utf8 = SvUTF8(*svp); - STRLEN len; - const char *name = SvPVx_const(*svp, len); - if(PL_stashcache) { + STRLEN len; + const char *name = SvPVx_const(*svp, len); + if(PL_stashcache) { DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%" SVf "'\n", SVfARG(*svp))); - (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD); + (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD); } ++svp; - hv_ename_delete(oldstash, name, len, name_utf8); - - if (!fetched_isarev) { - /* If the name deletion caused a name change, then we - * are not going to call mro_isa_changed_in with this - * name (and not at all if it has become anonymous) so - * we need to delete old isarev entries here, both - * those in the superclasses and this class's own list - * of subclasses. We simply delete the latter from - * PL_isarev, since we still need it. hv_delete morti- - * fies it for us, so sv_2mortal is not necessary. */ - if(HvENAME_HEK(oldstash) != enamehek) { - if(meta->isa && HvARRAY(meta->isa)) - mro_clean_isarev(meta->isa, name, len, 0, 0, - name_utf8 ? HVhek_UTF8 : 0); - isarev = (HV *)hv_delete(PL_isarev, name, + hv_ename_delete(oldstash, name, len, name_utf8); + + if (!fetched_isarev) { + /* If the name deletion caused a name change, then we + * are not going to call mro_isa_changed_in with this + * name (and not at all if it has become anonymous) so + * we need to delete old isarev entries here, both + * those in the superclasses and this class's own list + * of subclasses. We simply delete the latter from + * PL_isarev, since we still need it. hv_delete morti- + * fies it for us, so sv_2mortal is not necessary. */ + if(HvENAME_HEK(oldstash) != enamehek) { + if(meta->isa && HvARRAY(meta->isa)) + mro_clean_isarev(meta->isa, name, len, 0, 0, + name_utf8 ? HVhek_UTF8 : 0); + isarev = (HV *)hv_delete(PL_isarev, name, name_utf8 ? -(I32)len : (I32)len, 0); - fetched_isarev=TRUE; - } - } - } - } + fetched_isarev=TRUE; + } + } + } + } } check_stash: if(stash) { - if(SvTYPE(namesv) == SVt_PVAV) { - items = AvFILLp((AV *)namesv) + 1; - svp = AvARRAY((AV *)namesv); - } - else { - items = 1; - svp = &namesv; - } - while (items--) { + if(SvTYPE(namesv) == SVt_PVAV) { + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + } + else { + items = 1; + svp = &namesv; + } + while (items--) { const U32 name_utf8 = SvUTF8(*svp); - STRLEN len; - const char *name = SvPVx_const(*svp++, len); - hv_ename_add(stash, name, len, name_utf8); - } + STRLEN len; + const char *name = SvPVx_const(*svp++, len); + hv_ename_add(stash, name, len, name_utf8); + } /* Add it to the big list if it needs - * mro_isa_changed_in called on it. That happens if it was - * detached from the symbol table (so it had no HvENAME) before - * being assigned to the spot named by the 'name' variable, because - * its cached isa linearisation is now stale (the effective name - * having changed), and subclasses will then use that cache when - * mro_package_moved calls mro_isa_changed_in. (See - * [perl #77358].) - * - * If it did have a name, then its previous name is still - * used in isa caches, and there is no need for - * mro_package_moved to call mro_isa_changed_in. - */ - - entry - = (HE *) - hv_common( - seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0, - HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 - ); - if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no) - stash = NULL; - else { - HeVAL(entry) - = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no; - if(!stash_had_name) - { - struct mro_meta * const meta = HvMROMETA(stash); - (void) - hv_store( - stashes, (const char *)&stash, sizeof(HV *), - meta->isa - ? SvREFCNT_inc_simple_NN((SV *)meta->isa) - : &PL_sv_yes, - 0 - ); - CLEAR_LINEAR(meta); - } - } + * mro_isa_changed_in called on it. That happens if it was + * detached from the symbol table (so it had no HvENAME) before + * being assigned to the spot named by the 'name' variable, because + * its cached isa linearisation is now stale (the effective name + * having changed), and subclasses will then use that cache when + * mro_package_moved calls mro_isa_changed_in. (See + * [perl #77358].) + * + * If it did have a name, then its previous name is still + * used in isa caches, and there is no need for + * mro_package_moved to call mro_isa_changed_in. + */ + + entry + = (HE *) + hv_common( + seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0, + HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0 + ); + if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no) + stash = NULL; + else { + HeVAL(entry) + = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no; + if(!stash_had_name) + { + struct mro_meta * const meta = HvMROMETA(stash); + (void) + hv_store( + stashes, (const char *)&stash, sizeof(HV *), + meta->isa + ? SvREFCNT_inc_simple_NN((SV *)meta->isa) + : &PL_sv_yes, + 0 + ); + CLEAR_LINEAR(meta); + } + } } if(!stash && !oldstash) - /* Both stashes have been encountered already. */ - return; + /* Both stashes have been encountered already. */ + return; /* Add all the subclasses to the big list. */ if(!fetched_isarev) { - /* If oldstash is not null, then we can use its HvENAME to look up - the isarev hash, since all its subclasses will be listed there. - It will always have an HvENAME. It the HvENAME was removed - above, then fetch_isarev will be true, and this code will not be - reached. - - If oldstash is null, then this is an empty spot with no stash in - it, so subclasses could be listed in isarev hashes belonging to - any of the names, so we have to check all of them. - */ - assert(!oldstash || HvENAME(oldstash)); - if (oldstash) { - /* Extra variable to avoid a compiler warning */ - const HEK * const hvename = HvENAME_HEK(oldstash); - fetched_isarev = TRUE; - svp = hv_fetchhek(PL_isarev, hvename, 0); - if (svp) isarev = MUTABLE_HV(*svp); - } - else if(SvTYPE(namesv) == SVt_PVAV) { - items = AvFILLp((AV *)namesv) + 1; - svp = AvARRAY((AV *)namesv); - } - else { - items = 1; - svp = &namesv; - } + /* If oldstash is not null, then we can use its HvENAME to look up + the isarev hash, since all its subclasses will be listed there. + It will always have an HvENAME. It the HvENAME was removed + above, then fetch_isarev will be true, and this code will not be + reached. + + If oldstash is null, then this is an empty spot with no stash in + it, so subclasses could be listed in isarev hashes belonging to + any of the names, so we have to check all of them. + */ + assert(!oldstash || HvENAME(oldstash)); + if (oldstash) { + /* Extra variable to avoid a compiler warning */ + const HEK * const hvename = HvENAME_HEK(oldstash); + fetched_isarev = TRUE; + svp = hv_fetchhek(PL_isarev, hvename, 0); + if (svp) isarev = MUTABLE_HV(*svp); + } + else if(SvTYPE(namesv) == SVt_PVAV) { + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + } + else { + items = 1; + svp = &namesv; + } } if( isarev || !fetched_isarev ) { while (fetched_isarev || items--) { - HE *iter; - - if (!fetched_isarev) { - HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0); - if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue; - } - - hv_iterinit(isarev); - while((iter = hv_iternext(isarev))) { - HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0); - struct mro_meta * meta; - - if(!revstash) continue; - meta = HvMROMETA(revstash); - (void) - hv_store( - stashes, (const char *)&revstash, sizeof(HV *), - meta->isa - ? SvREFCNT_inc_simple_NN((SV *)meta->isa) - : &PL_sv_yes, - 0 - ); - CLEAR_LINEAR(meta); + HE *iter; + + if (!fetched_isarev) { + HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0); + if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue; } - if (fetched_isarev) break; + hv_iterinit(isarev); + while((iter = hv_iternext(isarev))) { + HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0); + struct mro_meta * meta; + + if(!revstash) continue; + meta = HvMROMETA(revstash); + (void) + hv_store( + stashes, (const char *)&revstash, sizeof(HV *), + meta->isa + ? SvREFCNT_inc_simple_NN((SV *)meta->isa) + : &PL_sv_yes, + 0 + ); + CLEAR_LINEAR(meta); + } + + if (fetched_isarev) break; } } @@ -1113,169 +1113,169 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes, /* Skip the entire loop if the hash is empty. */ if(oldstash && HvUSEDKEYS(oldstash)) { - xhv = (XPVHV*)SvANY(oldstash); - seen = (HV *) sv_2mortal((SV *)newHV()); - - /* Iterate through entries in the oldstash, adding them to the - list, meanwhile doing the equivalent of $seen{$key} = 1. - */ - - while (++riter <= (I32)xhv->xhv_max) { - entry = (HvARRAY(oldstash))[riter]; - - /* Iterate through the entries in this list */ - for(; entry; entry = HeNEXT(entry)) { - const char* key; - I32 len; - - /* If this entry is not a glob, ignore it. - Try the next. */ - if (!isGV(HeVAL(entry))) continue; - - key = hv_iterkey(entry, &len); - if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') - || (len == 1 && key[0] == ':')) { - HV * const oldsubstash = GvHV(HeVAL(entry)); - SV ** const stashentry - = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL; - HV *substash = NULL; - - /* Avoid main::main::main::... */ - if(oldsubstash == oldstash) continue; - - if( - ( - stashentry && *stashentry && isGV(*stashentry) - && (substash = GvHV(*stashentry)) - ) - || (oldsubstash && HvENAME_get(oldsubstash)) - ) - { - /* Add :: and the key (minus the trailing ::) - to each name. */ - SV *subname; - if(SvTYPE(namesv) == SVt_PVAV) { - SV *aname; - items = AvFILLp((AV *)namesv) + 1; - svp = AvARRAY((AV *)namesv); - subname = sv_2mortal((SV *)newAV()); - while (items--) { - aname = newSVsv(*svp++); - if (len == 1) - sv_catpvs(aname, ":"); - else { - sv_catpvs(aname, "::"); - sv_catpvn_flags( - aname, key, len-2, - HeUTF8(entry) - ? SV_CATUTF8 : SV_CATBYTES - ); - } - av_push((AV *)subname, aname); - } - } - else { - subname = sv_2mortal(newSVsv(namesv)); - if (len == 1) sv_catpvs(subname, ":"); - else { - sv_catpvs(subname, "::"); - sv_catpvn_flags( - subname, key, len-2, - HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES - ); - } - } - mro_gather_and_rename( - stashes, seen_stashes, - substash, oldsubstash, subname - ); - } - - (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0); - } - } - } + xhv = (XPVHV*)SvANY(oldstash); + seen = (HV *) sv_2mortal((SV *)newHV()); + + /* Iterate through entries in the oldstash, adding them to the + list, meanwhile doing the equivalent of $seen{$key} = 1. + */ + + while (++riter <= (I32)xhv->xhv_max) { + entry = (HvARRAY(oldstash))[riter]; + + /* Iterate through the entries in this list */ + for(; entry; entry = HeNEXT(entry)) { + const char* key; + I32 len; + + /* If this entry is not a glob, ignore it. + Try the next. */ + if (!isGV(HeVAL(entry))) continue; + + key = hv_iterkey(entry, &len); + if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') + || (len == 1 && key[0] == ':')) { + HV * const oldsubstash = GvHV(HeVAL(entry)); + SV ** const stashentry + = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL; + HV *substash = NULL; + + /* Avoid main::main::main::... */ + if(oldsubstash == oldstash) continue; + + if( + ( + stashentry && *stashentry && isGV(*stashentry) + && (substash = GvHV(*stashentry)) + ) + || (oldsubstash && HvENAME_get(oldsubstash)) + ) + { + /* Add :: and the key (minus the trailing ::) + to each name. */ + SV *subname; + if(SvTYPE(namesv) == SVt_PVAV) { + SV *aname; + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + subname = sv_2mortal((SV *)newAV()); + while (items--) { + aname = newSVsv(*svp++); + if (len == 1) + sv_catpvs(aname, ":"); + else { + sv_catpvs(aname, "::"); + sv_catpvn_flags( + aname, key, len-2, + HeUTF8(entry) + ? SV_CATUTF8 : SV_CATBYTES + ); + } + av_push((AV *)subname, aname); + } + } + else { + subname = sv_2mortal(newSVsv(namesv)); + if (len == 1) sv_catpvs(subname, ":"); + else { + sv_catpvs(subname, "::"); + sv_catpvn_flags( + subname, key, len-2, + HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES + ); + } + } + mro_gather_and_rename( + stashes, seen_stashes, + substash, oldsubstash, subname + ); + } + + (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0); + } + } + } } /* Skip the entire loop if the hash is empty. */ if (stash && HvUSEDKEYS(stash)) { - xhv = (XPVHV*)SvANY(stash); - riter = -1; - - /* Iterate through the new stash, skipping $seen{$key} items, - calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */ - while (++riter <= (I32)xhv->xhv_max) { - entry = (HvARRAY(stash))[riter]; - - /* Iterate through the entries in this list */ - for(; entry; entry = HeNEXT(entry)) { - const char* key; - I32 len; - - /* If this entry is not a glob, ignore it. - Try the next. */ - if (!isGV(HeVAL(entry))) continue; - - key = hv_iterkey(entry, &len); - if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') - || (len == 1 && key[0] == ':')) { - HV *substash; - - /* If this entry was seen when we iterated through the - oldstash, skip it. */ - if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue; - - /* We get here only if this stash has no corresponding - entry in the stash being replaced. */ - - substash = GvHV(HeVAL(entry)); - if(substash) { - SV *subname; - - /* Avoid checking main::main::main::... */ - if(substash == stash) continue; - - /* Add :: and the key (minus the trailing ::) - to each name. */ - if(SvTYPE(namesv) == SVt_PVAV) { - SV *aname; - items = AvFILLp((AV *)namesv) + 1; - svp = AvARRAY((AV *)namesv); - subname = sv_2mortal((SV *)newAV()); - while (items--) { - aname = newSVsv(*svp++); - if (len == 1) - sv_catpvs(aname, ":"); - else { - sv_catpvs(aname, "::"); - sv_catpvn_flags( - aname, key, len-2, - HeUTF8(entry) - ? SV_CATUTF8 : SV_CATBYTES - ); - } - av_push((AV *)subname, aname); - } - } - else { - subname = sv_2mortal(newSVsv(namesv)); - if (len == 1) sv_catpvs(subname, ":"); - else { - sv_catpvs(subname, "::"); - sv_catpvn_flags( - subname, key, len-2, - HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES - ); - } - } - mro_gather_and_rename( - stashes, seen_stashes, - substash, NULL, subname - ); - } - } - } - } + xhv = (XPVHV*)SvANY(stash); + riter = -1; + + /* Iterate through the new stash, skipping $seen{$key} items, + calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */ + while (++riter <= (I32)xhv->xhv_max) { + entry = (HvARRAY(stash))[riter]; + + /* Iterate through the entries in this list */ + for(; entry; entry = HeNEXT(entry)) { + const char* key; + I32 len; + + /* If this entry is not a glob, ignore it. + Try the next. */ + if (!isGV(HeVAL(entry))) continue; + + key = hv_iterkey(entry, &len); + if ((len > 1 && key[len-2] == ':' && key[len-1] == ':') + || (len == 1 && key[0] == ':')) { + HV *substash; + + /* If this entry was seen when we iterated through the + oldstash, skip it. */ + if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue; + + /* We get here only if this stash has no corresponding + entry in the stash being replaced. */ + + substash = GvHV(HeVAL(entry)); + if(substash) { + SV *subname; + + /* Avoid checking main::main::main::... */ + if(substash == stash) continue; + + /* Add :: and the key (minus the trailing ::) + to each name. */ + if(SvTYPE(namesv) == SVt_PVAV) { + SV *aname; + items = AvFILLp((AV *)namesv) + 1; + svp = AvARRAY((AV *)namesv); + subname = sv_2mortal((SV *)newAV()); + while (items--) { + aname = newSVsv(*svp++); + if (len == 1) + sv_catpvs(aname, ":"); + else { + sv_catpvs(aname, "::"); + sv_catpvn_flags( + aname, key, len-2, + HeUTF8(entry) + ? SV_CATUTF8 : SV_CATBYTES + ); + } + av_push((AV *)subname, aname); + } + } + else { + subname = sv_2mortal(newSVsv(namesv)); + if (len == 1) sv_catpvs(subname, ":"); + else { + sv_catpvs(subname, "::"); + sv_catpvn_flags( + subname, key, len-2, + HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES + ); + } + } + mro_gather_and_rename( + stashes, seen_stashes, + substash, NULL, subname + ); + } + } + } + } } } @@ -1340,7 +1340,7 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) /* else, invalidate the method caches of all child classes, but not itself */ if(isarev) { - HE* iter; + HE* iter; hv_iterinit(isarev); while((iter = hv_iternext(isarev))) { @@ -1374,15 +1374,15 @@ Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name) Perl_croak(aTHX_ "Invalid mro name: '%" SVf "'", name); if(meta->mro_which != which) { - if (meta->mro_linear_current && !meta->mro_linear_all) { - /* If we were storing something directly, put it in the hash before - we lose it. */ - Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, - MUTABLE_SV(meta->mro_linear_current)); - } - meta->mro_which = which; - /* Scrub our cached pointer to the private data. */ - meta->mro_linear_current = NULL; + if (meta->mro_linear_current && !meta->mro_linear_all) { + /* If we were storing something directly, put it in the hash before + we lose it. */ + Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, + MUTABLE_SV(meta->mro_linear_current)); + } + meta->mro_which = which; + /* Scrub our cached pointer to the private data. */ + meta->mro_linear_current = NULL; /* Only affects local method cache, not even child classes */ meta->cache_gen++; @@ -1412,7 +1412,7 @@ XS(XS_mro_method_changed_in) HV* class_stash; if(items != 1) - croak_xs_usage(cv, "classname"); + croak_xs_usage(cv, "classname"); classname = ST(0); @@ -1367,9 +1367,9 @@ S_mulexp10(NV value, I32 exponent) I32 bit; if (exponent == 0) - return value; + return value; if (value == 0) - return (NV)0; + return (NV)0; /* On OpenVMS VAX we by default use the D_FLOAT double format, * and that format does not have *easy* capabilities [1] for @@ -1393,24 +1393,24 @@ S_mulexp10(NV value, I32 exponent) #if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP) STMT_START { - const NV exp_v = log10(value); - if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP) - return NV_MAX; - if (exponent < 0) { - if (-(exponent + exp_v) >= NV_MAX_10_EXP) - return 0.0; - while (-exponent >= NV_MAX_10_EXP) { - /* combination does not overflow, but 10^(-exponent) does */ - value /= 10; - ++exponent; - } - } + const NV exp_v = log10(value); + if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP) + return NV_MAX; + if (exponent < 0) { + if (-(exponent + exp_v) >= NV_MAX_10_EXP) + return 0.0; + while (-exponent >= NV_MAX_10_EXP) { + /* combination does not overflow, but 10^(-exponent) does */ + value /= 10; + ++exponent; + } + } } STMT_END; #endif if (exponent < 0) { - negative = 1; - exponent = -exponent; + negative = 1; + exponent = -exponent; #ifdef NV_MAX_10_EXP /* for something like 1234 x 10^-309, the action of calculating * the intermediate value 10^309 then returning 1234 / (10^309) @@ -1433,9 +1433,9 @@ S_mulexp10(NV value, I32 exponent) # define FP_OVERFLOWS_TO_ZERO #endif for (bit = 1; exponent; bit <<= 1) { - if (exponent & bit) { - exponent ^= bit; - result *= power; + if (exponent & bit) { + exponent ^= bit; + result *= power; #ifdef FP_OVERFLOWS_TO_ZERO if (result == 0) # ifdef NV_INF @@ -1444,12 +1444,12 @@ S_mulexp10(NV value, I32 exponent) return value < 0 ? -FLT_MAX : FLT_MAX; # endif #endif - /* Floating point exceptions are supposed to be turned off, - * but if we're obviously done, don't risk another iteration. - */ - if (exponent == 0) break; - } - power *= power; + /* Floating point exceptions are supposed to be turned off, + * but if we're obviously done, don't risk another iteration. + */ + if (exponent == 0) break; + } + power *= power; } return negative ? value / result : value * result; } @@ -1646,15 +1646,15 @@ Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len) /* leading whitespace */ while (s < send && isSPACE(*s)) - ++s; + ++s; /* sign */ switch (*s) { - case '-': - negative = 1; - /* FALLTHROUGH */ - case '+': - ++s; + case '-': + negative = 1; + /* FALLTHROUGH */ + case '+': + ++s; } #endif @@ -1744,102 +1744,102 @@ Perl_my_atof3(pTHX_ const char* orig, NV* value, const STRLEN len) * large, we add the total to NV and start again */ while (s < send) { - if (isDIGIT(*s)) { - seen_digit = 1; - old_digit = digit; - digit = *s++ - '0'; - if (seen_dp) - exp_adjust[1]++; - - /* don't start counting until we see the first significant - * digit, eg the 5 in 0.00005... */ - if (!sig_digits && digit == 0) - continue; - - if (++sig_digits > MAX_SIG_DIGITS) { - /* limits of precision reached */ - if (digit > 5) { - ++accumulator[seen_dp]; - } else if (digit == 5) { - if (old_digit % 2) { /* round to even - Allen */ - ++accumulator[seen_dp]; - } - } - if (seen_dp) { - exp_adjust[1]--; - } else { - exp_adjust[0]++; - } - /* skip remaining digits */ - while (s < send && isDIGIT(*s)) { - ++s; - if (! seen_dp) { - exp_adjust[0]++; - } - } - /* warn of loss of precision? */ - } - else { - if (accumulator[seen_dp] > MAX_ACCUMULATE) { - /* add accumulator to result and start again */ - result[seen_dp] = S_mulexp10(result[seen_dp], - exp_acc[seen_dp]) - + (NV)accumulator[seen_dp]; - accumulator[seen_dp] = 0; - exp_acc[seen_dp] = 0; - } - accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit; - ++exp_acc[seen_dp]; - } - } - else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) { - seen_dp = 1; - if (sig_digits > MAX_SIG_DIGITS) { - while (s < send && isDIGIT(*s)) { - ++s; - } - break; - } - } - else { - break; - } + if (isDIGIT(*s)) { + seen_digit = 1; + old_digit = digit; + digit = *s++ - '0'; + if (seen_dp) + exp_adjust[1]++; + + /* don't start counting until we see the first significant + * digit, eg the 5 in 0.00005... */ + if (!sig_digits && digit == 0) + continue; + + if (++sig_digits > MAX_SIG_DIGITS) { + /* limits of precision reached */ + if (digit > 5) { + ++accumulator[seen_dp]; + } else if (digit == 5) { + if (old_digit % 2) { /* round to even - Allen */ + ++accumulator[seen_dp]; + } + } + if (seen_dp) { + exp_adjust[1]--; + } else { + exp_adjust[0]++; + } + /* skip remaining digits */ + while (s < send && isDIGIT(*s)) { + ++s; + if (! seen_dp) { + exp_adjust[0]++; + } + } + /* warn of loss of precision? */ + } + else { + if (accumulator[seen_dp] > MAX_ACCUMULATE) { + /* add accumulator to result and start again */ + result[seen_dp] = S_mulexp10(result[seen_dp], + exp_acc[seen_dp]) + + (NV)accumulator[seen_dp]; + accumulator[seen_dp] = 0; + exp_acc[seen_dp] = 0; + } + accumulator[seen_dp] = accumulator[seen_dp] * 10 + digit; + ++exp_acc[seen_dp]; + } + } + else if (!seen_dp && GROK_NUMERIC_RADIX(&s, send)) { + seen_dp = 1; + if (sig_digits > MAX_SIG_DIGITS) { + while (s < send && isDIGIT(*s)) { + ++s; + } + break; + } + } + else { + break; + } } result[0] = S_mulexp10(result[0], exp_acc[0]) + (NV)accumulator[0]; if (seen_dp) { - result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1]; + result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1]; } if (s < send && seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) { - bool expnegative = 0; - - ++s; - switch (*s) { - case '-': - expnegative = 1; - /* FALLTHROUGH */ - case '+': - ++s; - } - while (s < send && isDIGIT(*s)) - exponent = exponent * 10 + (*s++ - '0'); - if (expnegative) - exponent = -exponent; + bool expnegative = 0; + + ++s; + switch (*s) { + case '-': + expnegative = 1; + /* FALLTHROUGH */ + case '+': + ++s; + } + while (s < send && isDIGIT(*s)) + exponent = exponent * 10 + (*s++ - '0'); + if (expnegative) + exponent = -exponent; } /* now apply the exponent */ if (seen_dp) { - result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]) - + S_mulexp10(result[1],exponent-exp_adjust[1]); + result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]) + + S_mulexp10(result[1],exponent-exp_adjust[1]); } else { - result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]); + result[2] = S_mulexp10(result[0],exponent+exp_adjust[0]); } /* now apply the sign */ if (negative) - result[2] = -result[2]; + result[2] = -result[2]; *value = result[2]; return (char *)s; #else /* USE_PERL_ATOF */ @@ -65,7 +65,7 @@ typedef PERL_BITFIELD16 Optype; /* for efficiency, requires OPf_WANT_VOID == G_VOID etc */ #define OP_GIMME(op,dfl) \ - (((op)->op_flags & OPf_WANT) ? ((op)->op_flags & OPf_WANT) : dfl) + (((op)->op_flags & OPf_WANT) ? ((op)->op_flags & OPf_WANT) : dfl) #define OP_GIMME_REVERSE(flags) ((flags) & G_WANT) @@ -95,9 +95,9 @@ Deprecated. Use C<GIMME_V> instead. #define OPf_WANT_LIST 3 /* Want list of any length */ #define OPf_KIDS 4 /* There is a firstborn child. */ #define OPf_PARENS 8 /* This operator was parenthesized. */ - /* (Or block needs explicit scope entry.) */ + /* (Or block needs explicit scope entry.) */ #define OPf_REF 16 /* Certified reference. */ - /* (Return container, not containee). */ + /* (Return container, not containee). */ #define OPf_MOD 32 /* Will modify (lvalue). */ #define OPf_STACKED 64 /* Some arg is arriving on the stack. */ @@ -106,43 +106,43 @@ Deprecated. Use C<GIMME_V> instead. */ #define OPf_SPECIAL 128 /* Do something weird for this op: */ - /* On local LVAL, don't init local value. */ - /* On OP_SORT, subroutine is inlined. */ - /* On OP_NOT, inversion was implicit. */ - /* On OP_LEAVE, don't restore curpm, e.g. + /* On local LVAL, don't init local value. */ + /* On OP_SORT, subroutine is inlined. */ + /* On OP_NOT, inversion was implicit. */ + /* On OP_LEAVE, don't restore curpm, e.g. * /(...)/ while ...>; */ - /* On truncate, we truncate filehandle */ - /* On control verbs, we saw no label */ - /* On flipflop, we saw ... instead of .. */ - /* On UNOPs, saw bare parens, e.g. eof(). */ - /* On OP_CHDIR, handle (or bare parens) */ - /* On OP_NULL, saw a "do". */ - /* On OP_EXISTS, treat av as av, not avhv. */ - /* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */ - /* On regcomp, "use re 'eval'" was in scope */ - /* On RV2[ACGHS]V, don't create GV--in - defined()*/ - /* On OP_DBSTATE, indicates breakpoint - * (runtime property) */ - /* On OP_REQUIRE, was seen as CORE::require */ - /* On OP_(ENTER|LEAVE)WHEN, there's - no condition */ - /* On OP_SMARTMATCH, an implicit smartmatch */ - /* On OP_ANONHASH and OP_ANONLIST, create a - reference to the new anon hash or array */ - /* On OP_HELEM, OP_MULTIDEREF and OP_HSLICE, + /* On truncate, we truncate filehandle */ + /* On control verbs, we saw no label */ + /* On flipflop, we saw ... instead of .. */ + /* On UNOPs, saw bare parens, e.g. eof(). */ + /* On OP_CHDIR, handle (or bare parens) */ + /* On OP_NULL, saw a "do". */ + /* On OP_EXISTS, treat av as av, not avhv. */ + /* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */ + /* On regcomp, "use re 'eval'" was in scope */ + /* On RV2[ACGHS]V, don't create GV--in + defined()*/ + /* On OP_DBSTATE, indicates breakpoint + * (runtime property) */ + /* On OP_REQUIRE, was seen as CORE::require */ + /* On OP_(ENTER|LEAVE)WHEN, there's + no condition */ + /* On OP_SMARTMATCH, an implicit smartmatch */ + /* On OP_ANONHASH and OP_ANONLIST, create a + reference to the new anon hash or array */ + /* On OP_HELEM, OP_MULTIDEREF and OP_HSLICE, localization will be followed by assignment, so do not wipe the target if it is special (e.g. a glob or a magic SV) */ - /* On OP_MATCH, OP_SUBST & OP_TRANS, the - operand of a logical or conditional - that was optimised away, so it should - not be bound via =~ */ - /* On OP_CONST, from a constant CV */ - /* On OP_GLOB, two meanings: - - Before ck_glob, called as CORE::glob - - After ck_glob, use Perl glob function - */ + /* On OP_MATCH, OP_SUBST & OP_TRANS, the + operand of a logical or conditional + that was optimised away, so it should + not be bound via =~ */ + /* On OP_CONST, from a constant CV */ + /* On OP_GLOB, two meanings: + - Before ck_glob, called as CORE::glob + - After ck_glob, use Perl glob function + */ /* On OP_PADRANGE, push @_ */ /* On OP_DUMP, has no label */ /* On OP_UNSTACK, in a C-style for loop */ @@ -158,11 +158,11 @@ Deprecated. Use C<GIMME_V> instead. #if !defined(PERL_CORE) && !defined(PERL_EXT) # define GIMME \ - (PL_op->op_flags & OPf_WANT \ - ? ((PL_op->op_flags & OPf_WANT) == OPf_WANT_LIST \ - ? G_ARRAY \ - : G_SCALAR) \ - : dowantarray()) + (PL_op->op_flags & OPf_WANT \ + ? ((PL_op->op_flags & OPf_WANT) == OPf_WANT_LIST \ + ? G_ARRAY \ + : G_SCALAR) \ + : dowantarray()) #endif @@ -259,16 +259,16 @@ struct pmop { #endif U32 op_pmflags; union { - OP * op_pmreplroot; /* For OP_SUBST */ - PADOFFSET op_pmtargetoff; /* For OP_SPLIT lex ary or thr GV */ - GV * op_pmtargetgv; /* For OP_SPLIT non-threaded GV */ + OP * op_pmreplroot; /* For OP_SUBST */ + PADOFFSET op_pmtargetoff; /* For OP_SPLIT lex ary or thr GV */ + GV * op_pmtargetgv; /* For OP_SPLIT non-threaded GV */ } op_pmreplrootu; union { - OP * op_pmreplstart; /* Only used in OP_SUBST */ + OP * op_pmreplstart; /* Only used in OP_SUBST */ #ifdef USE_ITHREADS - PADOFFSET op_pmstashoff; /* Only used in OP_MATCH, with PMf_ONCE set */ + PADOFFSET op_pmstashoff; /* Only used in OP_MATCH, with PMf_ONCE set */ #else - HV * op_pmstash; + HV * op_pmstash; #endif } op_pmstashstartu; OP * op_code_list; /* list of (?{}) code blocks */ @@ -276,7 +276,7 @@ struct pmop { #ifdef USE_ITHREADS #define PM_GETRE(o) (SvTYPE(PL_regex_pad[(o)->op_pmoffset]) == SVt_REGEXP \ - ? (REGEXP*)(PL_regex_pad[(o)->op_pmoffset]) : NULL) + ? (REGEXP*)(PL_regex_pad[(o)->op_pmoffset]) : NULL) /* The assignment is just to enforce type safety (or at least get a warning). */ /* With first class regexps not via a reference one needs to assign @@ -288,7 +288,7 @@ struct pmop { #define PM_SETRE(o,r) STMT_START { \ REGEXP *const _pm_setre = (r); \ assert(_pm_setre); \ - PL_regex_pad[(o)->op_pmoffset] = MUTABLE_SV(_pm_setre); \ + PL_regex_pad[(o)->op_pmoffset] = MUTABLE_SV(_pm_setre); \ } STMT_END #else #define PM_GETRE(o) ((o)->op_pmregexp) @@ -390,16 +390,16 @@ struct pmop { ? PL_stashpad[(o)->op_pmstashstartu.op_pmstashoff] \ : NULL) # define PmopSTASH_set(o,hv) \ - (assert_((o)->op_pmflags & PMf_ONCE) \ - (o)->op_pmstashstartu.op_pmstashoff = \ - (hv) ? alloccopstash(hv) : 0) + (assert_((o)->op_pmflags & PMf_ONCE) \ + (o)->op_pmstashstartu.op_pmstashoff = \ + (hv) ? alloccopstash(hv) : 0) #else # define PmopSTASH(o) \ (((o)->op_pmflags & PMf_ONCE) ? (o)->op_pmstashstartu.op_pmstash : NULL) # if defined (DEBUGGING) && defined(PERL_USE_GCC_BRACE_GROUPS) # define PmopSTASH_set(o,hv) ({ \ - assert((o)->op_pmflags & PMf_ONCE); \ - ((o)->op_pmstashstartu.op_pmstash = (hv)); \ + assert((o)->op_pmflags & PMf_ONCE); \ + ((o)->op_pmstashstartu.op_pmstash = (hv)); \ }) # else # define PmopSTASH_set(o,hv) ((o)->op_pmstashstartu.op_pmstash = (hv)) @@ -506,12 +506,12 @@ typedef enum { # ifndef PERL_CORE # define IS_PADGV(v) (v && isGV(v)) # define IS_PADCONST(v) \ - (v && (SvREADONLY(v) || (SvIsCOW(v) && !SvLEN(v)))) + (v && (SvREADONLY(v) || (SvIsCOW(v) && !SvLEN(v)))) # endif # define cSVOPx_sv(v) (cSVOPx(v)->op_sv \ - ? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ)) + ? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ)) # define cSVOPx_svp(v) (cSVOPx(v)->op_sv \ - ? &cSVOPx(v)->op_sv : &PAD_SVl((v)->op_targ)) + ? &cSVOPx(v)->op_sv : &PAD_SVl((v)->op_targ)) # define cMETHOPx_rclass(v) PAD_SVl(cMETHOPx(v)->op_rclass_targ) #else # define cGVOPx_gv(o) ((GV*)cSVOPx(o)->op_sv) @@ -621,9 +621,9 @@ typedef enum { #define PERL_LOADMOD_DENY 0x1 /* no Module */ #define PERL_LOADMOD_NOIMPORT 0x2 /* use Module () */ #define PERL_LOADMOD_IMPORT_OPS 0x4 /* import arguments - are passed as a sin- - gle op tree, not a - list of SVs */ + are passed as a sin- + gle op tree, not a + list of SVs */ #if defined(PERL_IN_PERLY_C) || defined(PERL_IN_OP_C) || defined(PERL_IN_TOKE_C) #define ref(o, type) doref(o, type, TRUE) @@ -668,9 +668,9 @@ least an C<UNOP>. #endif #define NewOp(m,var,c,type) \ - (var = (type *) Perl_Slab_Alloc(aTHX_ c*sizeof(type))) + (var = (type *) Perl_Slab_Alloc(aTHX_ c*sizeof(type))) #define NewOpSz(m,var,size) \ - (var = (OP *) Perl_Slab_Alloc(aTHX_ size)) + (var = (OP *) Perl_Slab_Alloc(aTHX_ size)) #define FreeOp(p) Perl_Slab_Free(aTHX_ p) /* @@ -719,7 +719,7 @@ struct opslab { # define OPSLOT_HEADER STRUCT_OFFSET(OPSLOT, opslot_op) # define OpSLOT(o) (assert_(o->op_slabbed) \ - (OPSLOT *)(((char *)o)-OPSLOT_HEADER)) + (OPSLOT *)(((char *)o)-OPSLOT_HEADER)) /* the slab that owns this op */ # define OpMySLAB(o) \ @@ -732,14 +732,14 @@ struct opslab { ((OPSLOT*)(((I32 **)&(slab)->opslab_slots)+(offset))) # define OpslabREFCNT_dec(slab) \ - (((slab)->opslab_refcnt == 1) \ - ? opslab_free_nopad(slab) \ - : (void)--(slab)->opslab_refcnt) + (((slab)->opslab_refcnt == 1) \ + ? opslab_free_nopad(slab) \ + : (void)--(slab)->opslab_refcnt) /* Variant that does not null out the pads */ # define OpslabREFCNT_dec_padok(slab) \ - (((slab)->opslab_refcnt == 1) \ - ? opslab_free(slab) \ - : (void)--(slab)->opslab_refcnt) + (((slab)->opslab_refcnt == 1) \ + ? opslab_free(slab) \ + : (void)--(slab)->opslab_refcnt) #endif struct block_hooks { @@ -797,39 +797,39 @@ preprocessing token; the type of C<arg> depends on C<which>. #define BhkENABLE(hk, which) \ STMT_START { \ - BhkFLAGS(hk) |= BHKf_ ## which; \ - assert(BhkENTRY(hk, which)); \ + BhkFLAGS(hk) |= BHKf_ ## which; \ + assert(BhkENTRY(hk, which)); \ } STMT_END #define BhkDISABLE(hk, which) \ STMT_START { \ - BhkFLAGS(hk) &= ~(BHKf_ ## which); \ + BhkFLAGS(hk) &= ~(BHKf_ ## which); \ } STMT_END #define BhkENTRY_set(hk, which, ptr) \ STMT_START { \ - (hk)->which = ptr; \ - BhkENABLE(hk, which); \ + (hk)->which = ptr; \ + BhkENABLE(hk, which); \ } STMT_END #define CALL_BLOCK_HOOKS(which, arg) \ STMT_START { \ - if (PL_blockhooks) { \ - SSize_t i; \ - for (i = av_top_index(PL_blockhooks); i >= 0; i--) { \ - SV *sv = AvARRAY(PL_blockhooks)[i]; \ - BHK *hk; \ - \ - assert(SvIOK(sv)); \ - if (SvUOK(sv)) \ - hk = INT2PTR(BHK *, SvUVX(sv)); \ - else \ - hk = INT2PTR(BHK *, SvIVX(sv)); \ - \ - if (BhkENTRY(hk, which)) \ - BhkENTRY(hk, which)(aTHX_ arg); \ - } \ - } \ + if (PL_blockhooks) { \ + SSize_t i; \ + for (i = av_top_index(PL_blockhooks); i >= 0; i--) { \ + SV *sv = AvARRAY(PL_blockhooks)[i]; \ + BHK *hk; \ + \ + assert(SvIOK(sv)); \ + if (SvUOK(sv)) \ + hk = INT2PTR(BHK *, SvUVX(sv)); \ + else \ + hk = INT2PTR(BHK *, SvIVX(sv)); \ + \ + if (BhkENTRY(hk, which)) \ + BhkENTRY(hk, which)(aTHX_ arg); \ + } \ + } \ } STMT_END /* flags for rv2cv_op_cv */ @@ -924,8 +924,8 @@ typedef enum { #define XopENTRY_set(xop, which, to) \ STMT_START { \ - (xop)->which = (to); \ - (xop)->xop_flags |= XOPf_ ## which; \ + (xop)->which = (to); \ + (xop)->xop_flags |= XOPf_ ## which; \ } STMT_END #define XopENTRY(xop, which) \ @@ -937,8 +937,8 @@ typedef enum { #define XopDISABLE(xop, which) ((xop)->xop_flags &= ~XOPf_ ## which) #define XopENABLE(xop, which) \ STMT_START { \ - (xop)->xop_flags |= XOPf_ ## which; \ - assert(XopENTRY(xop, which)); \ + (xop)->xop_flags |= XOPf_ ## which; \ + assert(XopENTRY(xop, which)); \ } STMT_END #define Perl_custom_op_xop(x) \ @@ -1009,13 +1009,13 @@ C<sib> is non-null. For a higher-level interface, see C<L</op_sibling_splice>>. #define OP_NAME(o) ((o)->op_type == OP_CUSTOM \ ? XopENTRYCUSTOM(o, xop_name) \ - : PL_op_name[(o)->op_type]) + : PL_op_name[(o)->op_type]) #define OP_DESC(o) ((o)->op_type == OP_CUSTOM \ ? XopENTRYCUSTOM(o, xop_desc) \ - : PL_op_desc[(o)->op_type]) + : PL_op_desc[(o)->op_type]) #define OP_CLASS(o) ((o)->op_type == OP_CUSTOM \ - ? XopENTRYCUSTOM(o, xop_class) \ - : (PL_opargs[(o)->op_type] & OA_CLASS_MASK)) + ? XopENTRYCUSTOM(o, xop_class) \ + : (PL_opargs[(o)->op_type] & OA_CLASS_MASK)) #define OP_TYPE_IS(o, type) ((o) && (o)->op_type == (type)) #define OP_TYPE_IS_NN(o, type) ((o)->op_type == (type)) diff --git a/os2/dl_os2.c b/os2/dl_os2.c index f15c465f62..ccf2e1a84c 100644 --- a/os2/dl_os2.c +++ b/os2/dl_os2.c @@ -31,11 +31,11 @@ unsigned long _DLL_InitTerm(unsigned long modHandle, unsigned long flag) case 0: /* INIT */ /* Save handle */ dllHandle = modHandle; - handle_found = 1; + handle_found = 1; return TRUE; case 1: /* TERM */ - handle_found = 0; + handle_found = 0; dllHandle = (unsigned long)NULLHANDLE; return TRUE; } @@ -50,25 +50,25 @@ find_myself(void) { static APIRET APIENTRY (*pDosQueryModFromEIP) (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, - ULONG * Offset, ULONG Address); + ULONG * Offset, ULONG Address); HMODULE doscalls_h, mod; static int failed; ULONG obj, offset, rc; char buf[260]; if (failed) - return 0; + return 0; failed = 1; doscalls_h = (HMODULE)dlopen("DOSCALLS",0); if (!doscalls_h) - return 0; + return 0; /* {&doscalls_handle, NULL, 360}, */ /* DosQueryModFromEIP */ rc = DosQueryProcAddr(doscalls_h, 360, 0, (PFN*)&pDosQueryModFromEIP); if (rc) - return 0; + return 0; rc = pDosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, (ULONG)dlopen); if (rc) - return 0; + return 0; failed = 0; handle_found = 1; dllHandle = mod; @@ -78,66 +78,66 @@ find_myself(void) void * dlopen(const char *path, int mode) { - HMODULE handle; - char tmp[260]; - const char *beg, *dot; - ULONG rc; - unsigned fpflag = _control87(0,0); - - fail[0] = 0; - if (!path) { /* Our own handle. */ - if (handle_found || find_myself()) { - char dllname[260]; - - if (handle_loaded) - return (void*)dllHandle; - rc = DosQueryModuleName(dllHandle, sizeof(dllname), dllname); - if (rc) { - strcpy(fail, "can't find my DLL name by the handle"); - retcode = rc; - return 0; - } - rc = DosLoadModule(fail, sizeof fail, dllname, &handle); - if (rc) { - strcpy(fail, "can't load my own DLL"); - retcode = rc; - return 0; - } - handle_loaded = 1; - goto ret; - } - retcode = ERROR_MOD_NOT_FOUND; + HMODULE handle; + char tmp[260]; + const char *beg, *dot; + ULONG rc; + unsigned fpflag = _control87(0,0); + + fail[0] = 0; + if (!path) { /* Our own handle. */ + if (handle_found || find_myself()) { + char dllname[260]; + + if (handle_loaded) + return (void*)dllHandle; + rc = DosQueryModuleName(dllHandle, sizeof(dllname), dllname); + if (rc) { + strcpy(fail, "can't find my DLL name by the handle"); + retcode = rc; + return 0; + } + rc = DosLoadModule(fail, sizeof fail, dllname, &handle); + if (rc) { + strcpy(fail, "can't load my own DLL"); + retcode = rc; + return 0; + } + handle_loaded = 1; + goto ret; + } + retcode = ERROR_MOD_NOT_FOUND; strcpy(fail, "can't load from myself: compiled without -DDLOPEN_INITTERM"); - return 0; - } - if ((rc = DosLoadModule(fail, sizeof fail, (char*)path, &handle)) == 0) - goto ret; - - retcode = rc; - - if (strlen(path) >= sizeof(tmp)) - return NULL; - - /* Not found. Check for non-FAT name and try truncated name. */ - /* Don't know if this helps though... */ - for (beg = dot = path + strlen(path); - beg > path && !memCHRs(":/\\", *(beg-1)); - beg--) - if (*beg == '.') - dot = beg; - if (dot - beg > 8) { - int n = beg+8-path; - - memmove(tmp, path, n); - memmove(tmp+n, dot, strlen(dot)+1); - if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0) - goto ret; - } - handle = 0; + return 0; + } + if ((rc = DosLoadModule(fail, sizeof fail, (char*)path, &handle)) == 0) + goto ret; + + retcode = rc; + + if (strlen(path) >= sizeof(tmp)) + return NULL; + + /* Not found. Check for non-FAT name and try truncated name. */ + /* Don't know if this helps though... */ + for (beg = dot = path + strlen(path); + beg > path && !memCHRs(":/\\", *(beg-1)); + beg--) + if (*beg == '.') + dot = beg; + if (dot - beg > 8) { + int n = beg+8-path; + + memmove(tmp, path, n); + memmove(tmp+n, dot, strlen(dot)+1); + if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0) + goto ret; + } + handle = 0; ret: - _control87(fpflag, MCW_EM); /* Some modules reset FP flags on load */ - return (void *)handle; + _control87(fpflag, MCW_EM); /* Some modules reset FP flags on load */ + return (void *)handle; } #define ERROR_WRONG_PROCTYPE 0xffffffff @@ -145,51 +145,51 @@ dlopen(const char *path, int mode) void * dlsym(void *handle, const char *symbol) { - ULONG rc, type; - PFN addr; - - fail[0] = 0; - rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr); - if (rc == 0) { - rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type); - if (rc == 0 && type == PT_32BIT) - return (void *)addr; - rc = ERROR_WRONG_PROCTYPE; - } - retcode = rc; - return NULL; + ULONG rc, type; + PFN addr; + + fail[0] = 0; + rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr); + if (rc == 0) { + rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type); + if (rc == 0 && type == PT_32BIT) + return (void *)addr; + rc = ERROR_WRONG_PROCTYPE; + } + retcode = rc; + return NULL; } char * dlerror(void) { - static char buf[700]; - ULONG len; - char *err; - - if (retcode == 0) - return NULL; - if (retcode == ERROR_WRONG_PROCTYPE) - err = "Wrong procedure type"; - else - err = os2error(retcode); - len = strlen(err); - if (len > sizeof(buf) - 1) - len = sizeof(buf) - 1; - strncpy(buf, err, len+1); - if (fail[0] && len + strlen(fail) < sizeof(buf) - 100) - sprintf(buf + len, ", possible problematic module: '%s'", fail); - retcode = 0; - return buf; + static char buf[700]; + ULONG len; + char *err; + + if (retcode == 0) + return NULL; + if (retcode == ERROR_WRONG_PROCTYPE) + err = "Wrong procedure type"; + else + err = os2error(retcode); + len = strlen(err); + if (len > sizeof(buf) - 1) + len = sizeof(buf) - 1; + strncpy(buf, err, len+1); + if (fail[0] && len + strlen(fail) < sizeof(buf) - 100) + sprintf(buf + len, ", possible problematic module: '%s'", fail); + retcode = 0; + return buf; } int dlclose(void *handle) { - ULONG rc; + ULONG rc; - if ((rc = DosFreeModule((HMODULE)handle)) == 0) return 0; + if ((rc = DosFreeModule((HMODULE)handle)) == 0) return 0; - retcode = rc; - return 2; + retcode = rc; + return 2; } @@ -246,7 +246,7 @@ pthreads_state_string(enum pthreads_state state) { if (state < 0 || state >= sizeof(pthreads_states)/sizeof(*pthreads_states)) { snprintf(pthreads_state_buf, sizeof(pthreads_state_buf), - "unknown thread state %d", (int)state); + "unknown thread state %d", (int)state); return pthreads_state_buf; } return pthreads_states[state]; @@ -269,53 +269,53 @@ pthread_join(perl_os_thread tid, void **status) { MUTEX_LOCK(&start_thread_mutex); if (tid < 1 || tid >= thread_join_count) { - MUTEX_UNLOCK(&start_thread_mutex); - if (tid != pthread_not_existant) - Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid); - Perl_warn_nocontext("panic: join with a thread which could not start"); - *status = 0; - return 0; + MUTEX_UNLOCK(&start_thread_mutex); + if (tid != pthread_not_existant) + Perl_croak_nocontext("panic: join with a thread with strange ordinal %d", (int)tid); + Perl_warn_nocontext("panic: join with a thread which could not start"); + *status = 0; + return 0; } switch (thread_join_data[tid].state) { case pthreads_st_exited: - thread_join_data[tid].state = pthreads_st_exited_waited; - *status = thread_join_data[tid].status; - MUTEX_UNLOCK(&start_thread_mutex); - COND_SIGNAL(&thread_join_data[tid].cond); - break; + thread_join_data[tid].state = pthreads_st_exited_waited; + *status = thread_join_data[tid].status; + MUTEX_UNLOCK(&start_thread_mutex); + COND_SIGNAL(&thread_join_data[tid].cond); + break; case pthreads_st_waited: - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("join with a thread with a waiter"); - break; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("join with a thread with a waiter"); + break; case pthreads_st_norun: { - int state = (int)thread_join_data[tid].status; - - thread_join_data[tid].state = pthreads_st_none; - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("panic: join with a thread which could not run" - " due to attempt of tid reuse (state='%s')", - pthreads_state_string(state)); - break; + int state = (int)thread_join_data[tid].status; + + thread_join_data[tid].state = pthreads_st_none; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: join with a thread which could not run" + " due to attempt of tid reuse (state='%s')", + pthreads_state_string(state)); + break; } case pthreads_st_run: { - perl_cond cond; - - thread_join_data[tid].state = pthreads_st_waited; - thread_join_data[tid].status = (void *)status; - COND_INIT(&thread_join_data[tid].cond); - cond = thread_join_data[tid].cond; - COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); - COND_DESTROY(&cond); - MUTEX_UNLOCK(&start_thread_mutex); - break; + perl_cond cond; + + thread_join_data[tid].state = pthreads_st_waited; + thread_join_data[tid].status = (void *)status; + COND_INIT(&thread_join_data[tid].cond); + cond = thread_join_data[tid].cond; + COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); + COND_DESTROY(&cond); + MUTEX_UNLOCK(&start_thread_mutex); + break; } default: - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'", - pthreads_state_string(thread_join_data[tid].state)); - break; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: join with thread in unknown thread state: '%s'", + pthreads_state_string(thread_join_data[tid].state)); + break; } return 0; } @@ -327,9 +327,9 @@ typedef struct { } pthr_startit; /* The lock is used: - a) Since we temporarily usurp the caller interp, so malloc() may - use it to decide on debugging the call; - b) Since *args is on the caller's stack. + a) Since we temporarily usurp the caller interp, so malloc() may + use it to decide on debugging the call; + b) Since *args is on the caller's stack. */ void pthread_startit(void *arg1) @@ -341,40 +341,40 @@ pthread_startit(void *arg1) int state; if (tid <= 1) { - /* Can't croak, the setjmp() is not in scope... */ - char buf[80]; - - snprintf(buf, sizeof(buf), - "panic: thread with strange ordinal %d created\n\r", tid); - write(2,buf,strlen(buf)); - MUTEX_UNLOCK(&start_thread_mutex); - return; + /* Can't croak, the setjmp() is not in scope... */ + char buf[80]; + + snprintf(buf, sizeof(buf), + "panic: thread with strange ordinal %d created\n\r", tid); + write(2,buf,strlen(buf)); + MUTEX_UNLOCK(&start_thread_mutex); + return; } /* Until args.sub resets it, makes debugging Perl_malloc() work: */ PERL_SET_CONTEXT(0); if (tid >= thread_join_count) { - int oc = thread_join_count; - - thread_join_count = tid + 5 + tid/5; - if (thread_join_data) { - Renew(thread_join_data, thread_join_count, thread_join_t); - Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t); - } else { - Newxz(thread_join_data, thread_join_count, thread_join_t); - } + int oc = thread_join_count; + + thread_join_count = tid + 5 + tid/5; + if (thread_join_data) { + Renew(thread_join_data, thread_join_count, thread_join_t); + Zero(thread_join_data + oc, thread_join_count - oc, thread_join_t); + } else { + Newxz(thread_join_data, thread_join_count, thread_join_t); + } } if (thread_join_data[tid].state != pthreads_st_none) { - /* Can't croak, the setjmp() is not in scope... */ - char buf[80]; - - snprintf(buf, sizeof(buf), - "panic: attempt to reuse thread id %d (state='%s')\n\r", - tid, pthreads_state_string(thread_join_data[tid].state)); - write(2,buf,strlen(buf)); - thread_join_data[tid].status = (void*)thread_join_data[tid].state; - thread_join_data[tid].state = pthreads_st_norun; - MUTEX_UNLOCK(&start_thread_mutex); - return; + /* Can't croak, the setjmp() is not in scope... */ + char buf[80]; + + snprintf(buf, sizeof(buf), + "panic: attempt to reuse thread id %d (state='%s')\n\r", + tid, pthreads_state_string(thread_join_data[tid].state)); + write(2,buf,strlen(buf)); + thread_join_data[tid].status = (void*)thread_join_data[tid].state; + thread_join_data[tid].state = pthreads_st_norun; + MUTEX_UNLOCK(&start_thread_mutex); + return; } thread_join_data[tid].state = pthreads_st_run; /* Now that we copied/updated the guys, we may release the caller... */ @@ -383,35 +383,35 @@ pthread_startit(void *arg1) MUTEX_LOCK(&start_thread_mutex); switch (thread_join_data[tid].state) { case pthreads_st_waited: - COND_SIGNAL(&thread_join_data[tid].cond); - thread_join_data[tid].state = pthreads_st_none; - *((void**)thread_join_data[tid].status) = rc; - break; + COND_SIGNAL(&thread_join_data[tid].cond); + thread_join_data[tid].state = pthreads_st_none; + *((void**)thread_join_data[tid].status) = rc; + break; case pthreads_st_detached: - thread_join_data[tid].state = pthreads_st_none; - break; + thread_join_data[tid].state = pthreads_st_none; + break; case pthreads_st_run: - /* Somebody can wait on us; cannot exit, since OS can reuse the tid - and our waiter will get somebody else's status. */ - thread_join_data[tid].state = pthreads_st_exited; - thread_join_data[tid].status = rc; - COND_INIT(&thread_join_data[tid].cond); - COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); - COND_DESTROY(&thread_join_data[tid].cond); - thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ - break; + /* Somebody can wait on us; cannot exit, since OS can reuse the tid + and our waiter will get somebody else's status. */ + thread_join_data[tid].state = pthreads_st_exited; + thread_join_data[tid].status = rc; + COND_INIT(&thread_join_data[tid].cond); + COND_WAIT(&thread_join_data[tid].cond, &start_thread_mutex); + COND_DESTROY(&thread_join_data[tid].cond); + thread_join_data[tid].state = pthreads_st_none; /* Ready to reuse */ + break; default: - state = thread_join_data[tid].state; - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'", - pthreads_state_string(state)); + state = thread_join_data[tid].state; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: unexpected thread state on exit: '%s'", + pthreads_state_string(state)); } MUTEX_UNLOCK(&start_thread_mutex); } int pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr, - void *(*start_routine)(void*), void *arg) + void *(*start_routine)(void*), void *arg) { dTHX; pthr_startit args; @@ -424,11 +424,11 @@ pthread_create(perl_os_thread *tidp, const pthread_attr_t *attr, /* Test suite creates 31 extra threads; on machine without shared-memory-hogs this stack sizeis OK with 31: */ *tidp = _beginthread(pthread_startit, /*stack*/ NULL, - /*stacksize*/ 4*1024*1024, (void*)&args); + /*stacksize*/ 4*1024*1024, (void*)&args); if (*tidp == -1) { - *tidp = pthread_not_existant; - MUTEX_UNLOCK(&start_thread_mutex); - return EINVAL; + *tidp = pthread_not_existant; + MUTEX_UNLOCK(&start_thread_mutex); + return EINVAL; } MUTEX_LOCK(&start_thread_mutex); /* Wait for init to proceed */ MUTEX_UNLOCK(&start_thread_mutex); @@ -440,45 +440,45 @@ pthread_detach(perl_os_thread tid) { MUTEX_LOCK(&start_thread_mutex); if (tid < 1 || tid >= thread_join_count) { - MUTEX_UNLOCK(&start_thread_mutex); - if (tid != pthread_not_existant) - Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid); - Perl_warn_nocontext("detach of a thread which could not start"); - return 0; + MUTEX_UNLOCK(&start_thread_mutex); + if (tid != pthread_not_existant) + Perl_croak_nocontext("panic: detach of a thread with strange ordinal %d", (int)tid); + Perl_warn_nocontext("detach of a thread which could not start"); + return 0; } switch (thread_join_data[tid].state) { case pthreads_st_waited: - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("detach on a thread with a waiter"); - break; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("detach on a thread with a waiter"); + break; case pthreads_st_run: - thread_join_data[tid].state = pthreads_st_detached; - MUTEX_UNLOCK(&start_thread_mutex); - break; + thread_join_data[tid].state = pthreads_st_detached; + MUTEX_UNLOCK(&start_thread_mutex); + break; case pthreads_st_exited: - MUTEX_UNLOCK(&start_thread_mutex); - COND_SIGNAL(&thread_join_data[tid].cond); - break; + MUTEX_UNLOCK(&start_thread_mutex); + COND_SIGNAL(&thread_join_data[tid].cond); + break; case pthreads_st_detached: - MUTEX_UNLOCK(&start_thread_mutex); - Perl_warn_nocontext("detach on an already detached thread"); - break; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_warn_nocontext("detach on an already detached thread"); + break; case pthreads_st_norun: { - int state = (int)thread_join_data[tid].status; - - thread_join_data[tid].state = pthreads_st_none; - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("panic: detaching thread which could not run" - " due to attempt of tid reuse (state='%s')", - pthreads_state_string(state)); - break; + int state = (int)thread_join_data[tid].status; + + thread_join_data[tid].state = pthreads_st_none; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: detaching thread which could not run" + " due to attempt of tid reuse (state='%s')", + pthreads_state_string(state)); + break; } default: - MUTEX_UNLOCK(&start_thread_mutex); - Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'", - pthreads_state_string(thread_join_data[tid].state)); - break; + MUTEX_UNLOCK(&start_thread_mutex); + Perl_croak_nocontext("panic: detach of a thread with unknown thread state: '%s'", + pthreads_state_string(thread_join_data[tid].state)); + break; } return 0; } @@ -490,13 +490,13 @@ os2_cond_wait(perl_cond *c, perl_mutex *m) int rc; STRLEN n_a; if ((rc = DosResetEventSem(*c,&n_a)) && (rc != ERROR_ALREADY_RESET)) - Perl_rc = CheckOSError(rc), croak_with_os2error("panic: COND_WAIT-reset"); + Perl_rc = CheckOSError(rc), croak_with_os2error("panic: COND_WAIT-reset"); if (m) MUTEX_UNLOCK(m); if (CheckOSError(DosWaitEventSem(*c,SEM_INDEFINITE_WAIT)) - && (rc != ERROR_INTERRUPT)) - croak_with_os2error("panic: COND_WAIT"); + && (rc != ERROR_INTERRUPT)) + croak_with_os2error("panic: COND_WAIT"); if (rc == ERROR_INTERRUPT) - errno = EINTR; + errno = EINTR; if (m) MUTEX_LOCK(m); return 0; } @@ -533,8 +533,8 @@ static const struct { {&pmwin_handle, NULL, 912}, /* WinDispatchMsg */ {&pmwin_handle, NULL, 753}, /* WinGetLastError */ {&pmwin_handle, NULL, 705}, /* WinCancelShutdown */ - /* These are needed in extensions. - How to protect PMSHAPI: it comes through EMX functions? */ + /* These are needed in extensions. + How to protect PMSHAPI: it comes through EMX functions? */ {&rexx_handle, "RexxStart", 0}, {&rexx_handle, "RexxVariablePool", 0}, {&rexxapi_handle, "RexxRegisterFunctionExe", 0}, @@ -549,7 +549,7 @@ static const struct { {&pmshapi_handle, "PRF32WRITEPROFILEDATA", 0}, /* At least some of these do not work by name, since they need - WIN32 instead of WIN... */ + WIN32 instead of WIN... */ #if 0 These were generated with nm I:\emx\lib\os2.a | fgrep -f API-list | grep = > API-list-entries @@ -646,8 +646,8 @@ loadModule(const char *modname, int fail) HMODULE h = (HMODULE)dlopen(modname, 0); if (!h && fail) - Perl_croak_nocontext("Error loading module '%s': %s", - modname, dlerror()); + Perl_croak_nocontext("Error loading module '%s': %s", + modname, dlerror()); return h; } @@ -662,7 +662,7 @@ my_type() if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) - return -1; + return -1; return (pib->pib_ultype); } @@ -675,9 +675,9 @@ my_type_set(int type) PIB *pib; if (!(_emx_env & 0x200)) - Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */ + Perl_croak_nocontext("Can't set type on DOS"); /* not OS/2. */ if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) - croak_with_os2error("Error getting info blocks"); + croak_with_os2error("Error getting info blocks"); pib->pib_ultype = type; } @@ -685,54 +685,54 @@ PFN loadByOrdinal(enum entries_ordinals ord, int fail) { if (sizeof(loadOrdinals)/sizeof(loadOrdinals[0]) != ORD_NENTRIES) - Perl_croak_nocontext( - "Wrong size of loadOrdinals array: expected %d, actual %d", - sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES); + Perl_croak_nocontext( + "Wrong size of loadOrdinals array: expected %d, actual %d", + sizeof(loadOrdinals)/sizeof(loadOrdinals[0]), ORD_NENTRIES); if (ExtFCN[ord] == NULL) { - PFN fcn = (PFN)-1; - APIRET rc; - - if (!loadOrdinals[ord].dll->handle) { - if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */ - char *s = PerlEnv_getenv("PERL_ASIF_PM"); - - if (!s || !atoi(s)) { - /* The module will not function well without PM. - The usual way to detect PM is the existence of the mutex - \SEM32\PMDRAG.SEM. */ - HMTX hMtx = 0; - - if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM", - &hMtx))) - Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}", - loadOrdinals[ord].dll->modname); - DosCloseMutexSem(hMtx); - } - } - MUTEX_LOCK(&perlos2_state_mutex); - loadOrdinals[ord].dll->handle - = loadModule(loadOrdinals[ord].dll->modname, fail); - MUTEX_UNLOCK(&perlos2_state_mutex); - } - if (!loadOrdinals[ord].dll->handle) - return 0; /* Possible with FAIL==0 only */ - if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle, - loadOrdinals[ord].entrypoint, - loadOrdinals[ord].entryname,&fcn))) { - char buf[20], *s = (char*)loadOrdinals[ord].entryname; - - if (!fail) - return 0; - if (!s) - sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint); - Perl_croak_nocontext( - "This version of OS/2 does not support %s.%s", - loadOrdinals[ord].dll->modname, s); - } - ExtFCN[ord] = fcn; + PFN fcn = (PFN)-1; + APIRET rc; + + if (!loadOrdinals[ord].dll->handle) { + if (loadOrdinals[ord].dll->requires_pm && my_type() < 2) { /* FS */ + char *s = PerlEnv_getenv("PERL_ASIF_PM"); + + if (!s || !atoi(s)) { + /* The module will not function well without PM. + The usual way to detect PM is the existence of the mutex + \SEM32\PMDRAG.SEM. */ + HMTX hMtx = 0; + + if (CheckOSError(DosOpenMutexSem("\\SEM32\\PMDRAG.SEM", + &hMtx))) + Perl_croak_nocontext("Looks like we have no PM; will not load DLL %s without $ENV{PERL_ASIF_PM}", + loadOrdinals[ord].dll->modname); + DosCloseMutexSem(hMtx); + } + } + MUTEX_LOCK(&perlos2_state_mutex); + loadOrdinals[ord].dll->handle + = loadModule(loadOrdinals[ord].dll->modname, fail); + MUTEX_UNLOCK(&perlos2_state_mutex); + } + if (!loadOrdinals[ord].dll->handle) + return 0; /* Possible with FAIL==0 only */ + if (CheckOSError(DosQueryProcAddr(loadOrdinals[ord].dll->handle, + loadOrdinals[ord].entrypoint, + loadOrdinals[ord].entryname,&fcn))) { + char buf[20], *s = (char*)loadOrdinals[ord].entryname; + + if (!fail) + return 0; + if (!s) + sprintf(s = buf, "%d", loadOrdinals[ord].entrypoint); + Perl_croak_nocontext( + "This version of OS/2 does not support %s.%s", + loadOrdinals[ord].dll->modname, s); + } + ExtFCN[ord] = fcn; } if ((long)ExtFCN[ord] == -1) - Perl_croak_nocontext("panic queryaddr"); + Perl_croak_nocontext("panic queryaddr"); return ExtFCN[ord]; } @@ -742,7 +742,7 @@ init_PMWIN_entries(void) int i; for (i = ORD_WinInitialize; i <= ORD_WinCancelShutdown; i++) - ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1); + ((PFN*)&PMWIN_entries)[i - ORD_WinInitialize] = loadByOrdinal(i, 1); } /*****************************************************/ @@ -765,7 +765,7 @@ DeclVoidFuncByORD(endservent, ORD_ENDSERVENT, (void), ()) /* priorities */ static const signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged, - self inverse. */ + self inverse. */ #define QSS_INI_BUFFER 1024 ULONG (*pDosVerifyPidTid) (PID pid, TID tid); @@ -778,28 +778,28 @@ get_sysinfo(ULONG pid, ULONG flags) PQTOPLEVEL psi; if (pid) { - if (!pidtid_lookup) { - pidtid_lookup = 1; - *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0); - } - if (pDosVerifyPidTid) { /* Warp3 or later */ - /* Up to some fixpak QuerySysState() kills the system if a non-existent - pid is used. */ - if (CheckOSError(pDosVerifyPidTid(pid, 1))) - return 0; + if (!pidtid_lookup) { + pidtid_lookup = 1; + *(PFN*)&pDosVerifyPidTid = loadByOrdinal(ORD_DosVerifyPidTid, 0); + } + if (pDosVerifyPidTid) { /* Warp3 or later */ + /* Up to some fixpak QuerySysState() kills the system if a non-existent + pid is used. */ + if (CheckOSError(pDosVerifyPidTid(pid, 1))) + return 0; } } Newx(pbuffer, buf_len, char); /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */ rc = QuerySysState(flags, pid, pbuffer, buf_len); while (rc == ERROR_BUFFER_OVERFLOW) { - Renew(pbuffer, buf_len *= 2, char); - rc = QuerySysState(flags, pid, pbuffer, buf_len); + Renew(pbuffer, buf_len *= 2, char); + rc = QuerySysState(flags, pid, pbuffer, buf_len); } if (rc) { - FillOSError(rc); - Safefree(pbuffer); - return 0; + FillOSError(rc); + Safefree(pbuffer); + return 0; } psi = (PQTOPLEVEL)pbuffer; if (psi && pid && psi->procdata && pid != psi->procdata->pid) { @@ -836,28 +836,28 @@ setpriority(int which, int pid, int val) if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) { /* Do not change class. */ return CheckOSError(DosSetPriority((pid < 0) - ? PRTYS_PROCESSTREE : PRTYS_PROCESS, - 0, - (32 - val) % 32 - (prio & 0xFF), - abs(pid))) + ? PRTYS_PROCESSTREE : PRTYS_PROCESS, + 0, + (32 - val) % 32 - (prio & 0xFF), + abs(pid))) ? -1 : 0; } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ { /* Documentation claims one can change both class and basevalue, * but I find it wrong. */ /* Change class, but since delta == 0 denotes absolute 0, correct. */ if (CheckOSError(DosSetPriority((pid < 0) - ? PRTYS_PROCESSTREE : PRTYS_PROCESS, - priors[(32 - val) >> 5] + 1, - 0, - abs(pid)))) - return -1; + ? PRTYS_PROCESSTREE : PRTYS_PROCESS, + priors[(32 - val) >> 5] + 1, + 0, + abs(pid)))) + return -1; if ( ((32 - val) % 32) == 0 ) return 0; return CheckOSError(DosSetPriority((pid < 0) - ? PRTYS_PROCESSTREE : PRTYS_PROCESS, - 0, - (32 - val) % 32, - abs(pid))) - ? -1 : 0; + ? PRTYS_PROCESSTREE : PRTYS_PROCESS, + 0, + (32 - val) % 32, + abs(pid))) + ? -1 : 0; } } @@ -891,7 +891,7 @@ spawn_sighandler(int sig) */ if (spawn_killed) - sig = SIGKILL; /* Try harder. */ + sig = SIGKILL; /* Try harder. */ kill(spawn_pid, sig); spawn_killed = 1; } @@ -899,40 +899,40 @@ spawn_sighandler(int sig) static int result(pTHX_ int flag, int pid) { - int r, status; - Signal_t (*ihand)(); /* place to save signal during system() */ - Signal_t (*qhand)(); /* place to save signal during system() */ + int r, status; + Signal_t (*ihand)(); /* place to save signal during system() */ + Signal_t (*qhand)(); /* place to save signal during system() */ #ifndef __EMX__ - RESULTCODES res; - int rpid; + RESULTCODES res; + int rpid; #endif - if (pid < 0 || flag != 0) - return pid; + if (pid < 0 || flag != 0) + return pid; #ifdef __EMX__ - spawn_pid = pid; - spawn_killed = 0; - ihand = rsignal(SIGINT, &spawn_sighandler); - qhand = rsignal(SIGQUIT, &spawn_sighandler); - do { - r = wait4pid(pid, &status, 0); - } while (r == -1 && errno == EINTR); - rsignal(SIGINT, ihand); - rsignal(SIGQUIT, qhand); - - PL_statusvalue = (U16)status; - if (r < 0) - return -1; - return status & 0xFFFF; + spawn_pid = pid; + spawn_killed = 0; + ihand = rsignal(SIGINT, &spawn_sighandler); + qhand = rsignal(SIGQUIT, &spawn_sighandler); + do { + r = wait4pid(pid, &status, 0); + } while (r == -1 && errno == EINTR); + rsignal(SIGINT, ihand); + rsignal(SIGQUIT, qhand); + + PL_statusvalue = (U16)status; + if (r < 0) + return -1; + return status & 0xFFFF; #else - ihand = rsignal(SIGINT, SIG_IGN); - r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); - rsignal(SIGINT, ihand); - PL_statusvalue = res.codeResult << 8 | res.codeTerminate; - if (r) - return -1; - return PL_statusvalue; + ihand = rsignal(SIGINT, SIG_IGN); + r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); + rsignal(SIGINT, ihand); + PL_statusvalue = res.codeResult << 8 | res.codeTerminate; + if (r) + return -1; + return PL_statusvalue; #endif } @@ -952,19 +952,19 @@ file_type(char *path) ULONG apptype; if (!(_emx_env & 0x200)) - Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */ + Perl_croak_nocontext("file_type not implemented on DOS"); /* not OS/2. */ if (CheckOSError(DosQueryAppType(path, &apptype))) { - switch (rc) { - case ERROR_FILE_NOT_FOUND: - case ERROR_PATH_NOT_FOUND: - return -1; - case ERROR_ACCESS_DENIED: /* Directory with this name found? */ - return -3; - default: /* Found, but not an - executable, or some other - read error. */ - return -2; - } + switch (rc) { + case ERROR_FILE_NOT_FOUND: + case ERROR_PATH_NOT_FOUND: + return -1; + case ERROR_ACCESS_DENIED: /* Directory with this name found? */ + return -3; + default: /* Found, but not an + executable, or some other + read error. */ + return -2; + } } return apptype; } @@ -972,374 +972,374 @@ file_type(char *path) /* Spawn/exec a program, revert to shell if needed. */ extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, - EXCEPTIONREGISTRATIONRECORD *, + EXCEPTIONREGISTRATIONRECORD *, CONTEXTRECORD *, void *); int do_spawn_ve(pTHX_ SV *really, const char **argv, U32 flag, U32 execf, char *inicmd, U32 addflag) { - int trueflag = flag; - int rc, pass = 1; - char *real_name = NULL; /* Shut down the warning */ - char const * args[4]; - static const char * const fargs[4] - = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; - const char * const *argsp = fargs; - int nargs = 4; - int force_shell; - int new_stderr = -1, nostderr = 0; - int fl_stderr = 0; - STRLEN n_a; - char *buf; - PerlIO *file; - - if (flag == P_WAIT) - flag = P_NOWAIT; - if (really) { - real_name = SvPV(really, n_a); - real_name = savepv(real_name); - SAVEFREEPV(real_name); - if (!*real_name) - really = NULL; - } + int trueflag = flag; + int rc, pass = 1; + char *real_name = NULL; /* Shut down the warning */ + char const * args[4]; + static const char * const fargs[4] + = { "/bin/sh", "-c", "\"$@\"", "spawn-via-shell", }; + const char * const *argsp = fargs; + int nargs = 4; + int force_shell; + int new_stderr = -1, nostderr = 0; + int fl_stderr = 0; + STRLEN n_a; + char *buf; + PerlIO *file; + + if (flag == P_WAIT) + flag = P_NOWAIT; + if (really) { + real_name = SvPV(really, n_a); + real_name = savepv(real_name); + SAVEFREEPV(real_name); + if (!*real_name) + really = NULL; + } retry: - if (strEQ(argv[0],"/bin/sh")) - argv[0] = PL_sh_path; - - /* We should check PERL_SH* and PERLLIB_* as well? */ - if (!really || pass >= 2) - real_name = argv[0]; - if (real_name[0] != '/' && real_name[0] != '\\' - && !(real_name[0] && real_name[1] == ':' - && (real_name[2] == '/' || real_name[2] != '\\')) - ) /* will spawnvp use PATH? */ - TAINT_ENV(); /* testing IFS here is overkill, probably */ + if (strEQ(argv[0],"/bin/sh")) + argv[0] = PL_sh_path; + + /* We should check PERL_SH* and PERLLIB_* as well? */ + if (!really || pass >= 2) + real_name = argv[0]; + if (real_name[0] != '/' && real_name[0] != '\\' + && !(real_name[0] && real_name[1] == ':' + && (real_name[2] == '/' || real_name[2] != '\\')) + ) /* will spawnvp use PATH? */ + TAINT_ENV(); /* testing IFS here is overkill, probably */ reread: - force_shell = 0; - if (_emx_env & 0x200) { /* OS/2. */ - int type = file_type(real_name); - type_again: - if (type == -1) { /* Not found */ - errno = ENOENT; - rc = -1; - goto do_script; - } - else if (type == -2) { /* Not an EXE */ - errno = ENOEXEC; - rc = -1; - goto do_script; - } - else if (type == -3) { /* Is a directory? */ - /* Special-case this */ - char tbuf[512]; - int l = strlen(real_name); - - if (l + 5 <= sizeof tbuf) { - strcpy(tbuf, real_name); - strcpy(tbuf + l, ".exe"); - type = file_type(tbuf); - if (type >= -3) - goto type_again; - } - - errno = ENOEXEC; - rc = -1; - goto do_script; - } - switch (type & 7) { - /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */ - case FAPPTYP_WINDOWAPI: - { /* Apparently, kids are started basing on startup type, not the morphed type */ - if (os2_mytype != 3) { /* not PM */ - if (flag == P_NOWAIT) - flag = P_PM; - else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d", - flag, os2_mytype); - } - } - break; - case FAPPTYP_NOTWINDOWCOMPAT: - { - if (os2_mytype != 0) { /* not full screen */ - if (flag == P_NOWAIT) - flag = P_SESSION; - else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d", - flag, os2_mytype); - } - } - break; - case FAPPTYP_NOTSPEC: - /* Let the shell handle this... */ - force_shell = 1; - buf = ""; /* Pacify a warning */ - file = 0; /* Pacify a warning */ - goto doshell_args; - break; - } - } - - if (addflag) { - addflag = 0; - new_stderr = dup(2); /* Preserve stderr */ - if (new_stderr == -1) { - if (errno == EBADF) - nostderr = 1; - else { - rc = -1; - goto finish; - } - } else - fl_stderr = fcntl(2, F_GETFD); - rc = dup2(1,2); - if (rc == -1) - goto finish; - fcntl(new_stderr, F_SETFD, FD_CLOEXEC); - } + force_shell = 0; + if (_emx_env & 0x200) { /* OS/2. */ + int type = file_type(real_name); + type_again: + if (type == -1) { /* Not found */ + errno = ENOENT; + rc = -1; + goto do_script; + } + else if (type == -2) { /* Not an EXE */ + errno = ENOEXEC; + rc = -1; + goto do_script; + } + else if (type == -3) { /* Is a directory? */ + /* Special-case this */ + char tbuf[512]; + int l = strlen(real_name); + + if (l + 5 <= sizeof tbuf) { + strcpy(tbuf, real_name); + strcpy(tbuf + l, ".exe"); + type = file_type(tbuf); + if (type >= -3) + goto type_again; + } + + errno = ENOEXEC; + rc = -1; + goto do_script; + } + switch (type & 7) { + /* Ignore WINDOWCOMPAT and FAPI, start them the same type we are. */ + case FAPPTYP_WINDOWAPI: + { /* Apparently, kids are started basing on startup type, not the morphed type */ + if (os2_mytype != 3) { /* not PM */ + if (flag == P_NOWAIT) + flag = P_PM; + else if ((flag & 7) != P_PM && (flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting PM process with flag=%d, mytype=%d", + flag, os2_mytype); + } + } + break; + case FAPPTYP_NOTWINDOWCOMPAT: + { + if (os2_mytype != 0) { /* not full screen */ + if (flag == P_NOWAIT) + flag = P_SESSION; + else if ((flag & 7) != P_SESSION && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Starting Full Screen process with flag=%d, mytype=%d", + flag, os2_mytype); + } + } + break; + case FAPPTYP_NOTSPEC: + /* Let the shell handle this... */ + force_shell = 1; + buf = ""; /* Pacify a warning */ + file = 0; /* Pacify a warning */ + goto doshell_args; + break; + } + } + + if (addflag) { + addflag = 0; + new_stderr = dup(2); /* Preserve stderr */ + if (new_stderr == -1) { + if (errno == EBADF) + nostderr = 1; + else { + rc = -1; + goto finish; + } + } else + fl_stderr = fcntl(2, F_GETFD); + rc = dup2(1,2); + if (rc == -1) + goto finish; + fcntl(new_stderr, F_SETFD, FD_CLOEXEC); + } #if 0 - rc = result(aTHX_ trueflag, spawnvp(flag,real_name,argv)); + rc = result(aTHX_ trueflag, spawnvp(flag,real_name,argv)); #else - if (execf == EXECF_TRUEEXEC) - rc = execvp(real_name,argv); - else if (execf == EXECF_EXEC) - rc = spawnvp(trueflag | P_OVERLAY,real_name,argv); - else if (execf == EXECF_SPAWN_NOWAIT) - rc = spawnvp(flag,real_name,argv); + if (execf == EXECF_TRUEEXEC) + rc = execvp(real_name,argv); + else if (execf == EXECF_EXEC) + rc = spawnvp(trueflag | P_OVERLAY,real_name,argv); + else if (execf == EXECF_SPAWN_NOWAIT) + rc = spawnvp(flag,real_name,argv); else if (execf == EXECF_SYNC) - rc = spawnvp(trueflag,real_name,argv); + rc = spawnvp(trueflag,real_name,argv); else /* EXECF_SPAWN, EXECF_SPAWN_BYFLAG */ - rc = result(aTHX_ trueflag, - spawnvp(flag,real_name,argv)); + rc = result(aTHX_ trueflag, + spawnvp(flag,real_name,argv)); #endif - if (rc < 0 && pass == 1) { - do_script: - if (real_name == argv[0]) { - int err = errno; - - if (err == ENOENT || err == ENOEXEC) { - /* No such file, or is a script. */ - /* Try adding script extensions to the file name, and - search on PATH. */ - char *scr = find_script(argv[0], TRUE, NULL, 0); - - if (scr) { - char *s = 0, *s1; - SV *scrsv = sv_2mortal(newSVpv(scr, 0)); - SV *bufsv = sv_newmortal(); + if (rc < 0 && pass == 1) { + do_script: + if (real_name == argv[0]) { + int err = errno; + + if (err == ENOENT || err == ENOEXEC) { + /* No such file, or is a script. */ + /* Try adding script extensions to the file name, and + search on PATH. */ + char *scr = find_script(argv[0], TRUE, NULL, 0); + + if (scr) { + char *s = 0, *s1; + SV *scrsv = sv_2mortal(newSVpv(scr, 0)); + SV *bufsv = sv_newmortal(); Safefree(scr); - scr = SvPV(scrsv, n_a); /* free()ed later */ + scr = SvPV(scrsv, n_a); /* free()ed later */ - file = PerlIO_open(scr, "r"); - argv[0] = scr; - if (!file) - goto panic_file; + file = PerlIO_open(scr, "r"); + argv[0] = scr; + if (!file) + goto panic_file; - buf = sv_gets(bufsv, file, 0 /* No append */); - if (!buf) - buf = ""; /* XXX Needed? */ - if (!buf[0]) { /* Empty... */ + buf = sv_gets(bufsv, file, 0 /* No append */); + if (!buf) + buf = ""; /* XXX Needed? */ + if (!buf[0]) { /* Empty... */ struct stat statbuf; - PerlIO_close(file); - /* Special case: maybe from -Zexe build, so - there is an executable around (contrary to - documentation, DosQueryAppType sometimes (?) - does not append ".exe", so we could have - reached this place). */ - sv_catpvs(scrsv, ".exe"); - argv[0] = scr = SvPV(scrsv, n_a); /* Reload */ + PerlIO_close(file); + /* Special case: maybe from -Zexe build, so + there is an executable around (contrary to + documentation, DosQueryAppType sometimes (?) + does not append ".exe", so we could have + reached this place). */ + sv_catpvs(scrsv, ".exe"); + argv[0] = scr = SvPV(scrsv, n_a); /* Reload */ if (PerlLIO_stat(scr,&statbuf) >= 0 && !S_ISDIR(statbuf.st_mode)) { /* Found */ - real_name = scr; - pass++; - goto reread; - } else { /* Restore */ - SvCUR_set(scrsv, SvCUR(scrsv) - 4); - *SvEND(scrsv) = 0; - } - } - if (PerlIO_close(file) != 0) { /* Failure */ - panic_file: - if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s", - scr, Strerror(errno)); - buf = ""; /* Not #! */ - goto doshell_args; - } - if (buf[0] == '#') { - if (buf[1] == '!') - s = buf + 2; - } else if (buf[0] == 'e') { - if (strBEGINs(buf, "extproc") - && isSPACE(buf[7])) - s = buf + 8; - } else if (buf[0] == 'E') { - if (strBEGINs(buf, "EXTPROC") - && isSPACE(buf[7])) - s = buf + 8; - } - if (!s) { - buf = ""; /* Not #! */ - goto doshell_args; - } - - s1 = s; - nargs = 0; - argsp = args; - while (1) { - /* Do better than pdksh: allow a few args, - strip trailing whitespace. */ - while (isSPACE(*s)) - s++; - if (*s == 0) - break; - if (nargs == 4) { - nargs = -1; - break; - } - args[nargs++] = s; - while (*s && !isSPACE(*s)) - s++; - if (*s == 0) - break; - *s++ = 0; - } - if (nargs == -1) { - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"", - s1 - buf, buf, scr); - nargs = 4; - argsp = fargs; - } - /* Can jump from far, buf/file invalid if force_shell: */ - doshell_args: - { - char **a = argv; - const char *exec_args[2]; - - if (force_shell - || (!buf[0] && file)) { /* File without magic */ - /* In fact we tried all what pdksh would - try. There is no point in calling - pdksh, we may just emulate its logic. */ - char *shell = PerlEnv_getenv("EXECSHELL"); - char *shell_opt = NULL; - if (!shell) { - char *s; - - shell_opt = "/c"; - shell = PerlEnv_getenv("OS2_SHELL"); - if (inicmd) { /* No spaces at start! */ - s = inicmd; - while (*s && !isSPACE(*s)) { - if (*s++ == '/') { - inicmd = NULL; /* Cannot use */ - break; - } - } - } - if (!inicmd) { - s = argv[0]; - while (*s) { - /* Dosish shells will choke on slashes - in paths, fortunately, this is - important for zeroth arg only. */ - if (*s == '/') - *s = '\\'; - s++; - } - } - } - /* If EXECSHELL is set, we do not set */ - - if (!shell) - shell = ((_emx_env & 0x200) - ? "c:/os2/cmd.exe" - : "c:/command.com"); - nargs = shell_opt ? 2 : 1; /* shell file args */ - exec_args[0] = shell; - exec_args[1] = shell_opt; - argsp = exec_args; - if (nargs == 2 && inicmd) { - /* Use the original cmd line */ - /* XXXX This is good only until we refuse - quoted arguments... */ - argv[0] = inicmd; - argv[1] = NULL; - } - } else if (!buf[0] && inicmd) { /* No file */ - /* Start with the original cmdline. */ - /* XXXX This is good only until we refuse - quoted arguments... */ - - argv[0] = inicmd; - argv[1] = NULL; - nargs = 2; /* shell -c */ - } - - while (a[1]) /* Get to the end */ - a++; - a++; /* Copy finil NULL too */ - while (a >= argv) { - *(a + nargs) = *a; /* argv was preallocated to be - long enough. */ - a--; - } - while (--nargs >= 0) /* XXXX Discard const... */ - argv[nargs] = (char*)argsp[nargs]; - /* Enable pathless exec if #! (as pdksh). */ - pass = (buf[0] == '#' ? 2 : 3); - goto retry; - } - } - /* Not found: restore errno */ - errno = err; - } - } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */ - if (rc < 0 && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'", - ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) - ? "spawn" : "exec"), - real_name, argv[0]); - goto warned; - } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */ - if (rc < 0 && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)", - ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) - ? "spawn" : "exec"), - real_name, argv[0]); - goto warned; - } - } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */ - char *no_dir = strrchr(argv[0], '/'); - - /* Do as pdksh port does: if not found with /, try without - path. */ - if (no_dir) { - argv[0] = no_dir + 1; - pass++; - goto retry; - } - } - if (rc < 0 && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n", - ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) - ? "spawn" : "exec"), - real_name, Strerror(errno)); + real_name = scr; + pass++; + goto reread; + } else { /* Restore */ + SvCUR_set(scrsv, SvCUR(scrsv) - 4); + *SvEND(scrsv) = 0; + } + } + if (PerlIO_close(file) != 0) { /* Failure */ + panic_file: + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Error reading \"%s\": %s", + scr, Strerror(errno)); + buf = ""; /* Not #! */ + goto doshell_args; + } + if (buf[0] == '#') { + if (buf[1] == '!') + s = buf + 2; + } else if (buf[0] == 'e') { + if (strBEGINs(buf, "extproc") + && isSPACE(buf[7])) + s = buf + 8; + } else if (buf[0] == 'E') { + if (strBEGINs(buf, "EXTPROC") + && isSPACE(buf[7])) + s = buf + 8; + } + if (!s) { + buf = ""; /* Not #! */ + goto doshell_args; + } + + s1 = s; + nargs = 0; + argsp = args; + while (1) { + /* Do better than pdksh: allow a few args, + strip trailing whitespace. */ + while (isSPACE(*s)) + s++; + if (*s == 0) + break; + if (nargs == 4) { + nargs = -1; + break; + } + args[nargs++] = s; + while (*s && !isSPACE(*s)) + s++; + if (*s == 0) + break; + *s++ = 0; + } + if (nargs == -1) { + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Too many args on %.*s line of \"%s\"", + s1 - buf, buf, scr); + nargs = 4; + argsp = fargs; + } + /* Can jump from far, buf/file invalid if force_shell: */ + doshell_args: + { + char **a = argv; + const char *exec_args[2]; + + if (force_shell + || (!buf[0] && file)) { /* File without magic */ + /* In fact we tried all what pdksh would + try. There is no point in calling + pdksh, we may just emulate its logic. */ + char *shell = PerlEnv_getenv("EXECSHELL"); + char *shell_opt = NULL; + if (!shell) { + char *s; + + shell_opt = "/c"; + shell = PerlEnv_getenv("OS2_SHELL"); + if (inicmd) { /* No spaces at start! */ + s = inicmd; + while (*s && !isSPACE(*s)) { + if (*s++ == '/') { + inicmd = NULL; /* Cannot use */ + break; + } + } + } + if (!inicmd) { + s = argv[0]; + while (*s) { + /* Dosish shells will choke on slashes + in paths, fortunately, this is + important for zeroth arg only. */ + if (*s == '/') + *s = '\\'; + s++; + } + } + } + /* If EXECSHELL is set, we do not set */ + + if (!shell) + shell = ((_emx_env & 0x200) + ? "c:/os2/cmd.exe" + : "c:/command.com"); + nargs = shell_opt ? 2 : 1; /* shell file args */ + exec_args[0] = shell; + exec_args[1] = shell_opt; + argsp = exec_args; + if (nargs == 2 && inicmd) { + /* Use the original cmd line */ + /* XXXX This is good only until we refuse + quoted arguments... */ + argv[0] = inicmd; + argv[1] = NULL; + } + } else if (!buf[0] && inicmd) { /* No file */ + /* Start with the original cmdline. */ + /* XXXX This is good only until we refuse + quoted arguments... */ + + argv[0] = inicmd; + argv[1] = NULL; + nargs = 2; /* shell -c */ + } + + while (a[1]) /* Get to the end */ + a++; + a++; /* Copy finil NULL too */ + while (a >= argv) { + *(a + nargs) = *a; /* argv was preallocated to be + long enough. */ + a--; + } + while (--nargs >= 0) /* XXXX Discard const... */ + argv[nargs] = (char*)argsp[nargs]; + /* Enable pathless exec if #! (as pdksh). */ + pass = (buf[0] == '#' ? 2 : 3); + goto retry; + } + } + /* Not found: restore errno */ + errno = err; + } + } else if (errno == ENOEXEC) { /* Cannot transfer `real_name' via shell. */ + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s script `%s' with ARGV[0] being `%s'", + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + real_name, argv[0]); + goto warned; + } else if (errno == ENOENT) { /* Cannot transfer `real_name' via shell. */ + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)", + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + real_name, argv[0]); + goto warned; + } + } else if (rc < 0 && pass == 2 && errno == ENOENT) { /* File not found */ + char *no_dir = strrchr(argv[0], '/'); + + /* Do as pdksh port does: if not found with /, try without + path. */ + if (no_dir) { + argv[0] = no_dir + 1; + pass++; + goto retry; + } + } + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s\n", + ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) + ? "spawn" : "exec"), + real_name, Strerror(errno)); warned: - if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) - && ((trueflag & 0xFF) == P_WAIT)) - rc = -1; + if (rc < 0 && (execf != EXECF_SPAWN_NOWAIT) + && ((trueflag & 0xFF) == P_WAIT)) + rc = -1; finish: if (new_stderr != -1) { /* How can we use error codes? */ - dup2(new_stderr, 2); - close(new_stderr); - fcntl(2, F_SETFD, fl_stderr); + dup2(new_stderr, 2); + close(new_stderr); + fcntl(2, F_SETFD, fl_stderr); } else if (nostderr) close(2); return rc; @@ -1357,13 +1357,13 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) ENTER; #ifdef TRYSHELL if ((shell = PerlEnv_getenv("EMXSHELL")) != NULL) - copt = "-c"; + copt = "-c"; else if ((shell = PerlEnv_getenv("SHELL")) != NULL) - copt = "-c"; + copt = "-c"; else if ((shell = PerlEnv_getenv("COMSPEC")) != NULL) - copt = "/C"; + copt = "/C"; else - shell = "cmd.exe"; + shell = "cmd.exe"; #else /* Consensus on perl5-porters is that it is _very_ important to have a shell which will not change between computers with the @@ -1374,81 +1374,81 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) #endif while (*cmd && isSPACE(*cmd)) - cmd++; + cmd++; if (strBEGINs(cmd,"/bin/sh") && isSPACE(cmd[7])) { - STRLEN l = strlen(PL_sh_path); - - Newx(news, strlen(cmd) - 7 + l + 1, char); - strcpy(news, PL_sh_path); - strcpy(news + l, cmd + 7); - cmd = news; + STRLEN l = strlen(PL_sh_path); + + Newx(news, strlen(cmd) - 7 + l + 1, char); + strcpy(news, PL_sh_path); + strcpy(news + l, cmd + 7); + cmd = news; } /* save an extra exec if possible */ /* see if there are shell metacharacters in it */ if (*cmd == '.' && isSPACE(cmd[1])) - goto doshell; + goto doshell; if (strBEGINs(cmd,"exec") && isSPACE(cmd[4])) - goto doshell; + goto doshell; for (s = cmd; *s && isALPHA(*s); s++) ; /* catch VAR=val gizmo */ if (*s == '=') - goto doshell; + goto doshell; for (s = cmd; *s; s++) { - if (*s != ' ' && !isALPHA(*s) && memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) { - if (*s == '\n' && s[1] == '\0') { - *s = '\0'; - break; - } else if (*s == '\\' && !seenspace) { - continue; /* Allow backslashes in names */ - } else if (*s == '>' && s >= cmd + 3 - && s[-1] == '2' && s[1] == '&' && s[2] == '1' - && isSPACE(s[-2]) ) { - char *t = s + 3; - - while (*t && isSPACE(*t)) - t++; - if (!*t) { - s[-2] = '\0'; - mergestderr = 1; - break; /* Allow 2>&1 as the last thing */ - } - } - /* We do not convert this to do_spawn_ve since shell - should be smart enough to start itself gloriously. */ - doshell: - if (execf == EXECF_TRUEEXEC) + if (*s != ' ' && !isALPHA(*s) && memCHRs("$&*(){}[]'\";\\|?<>~`\n",*s)) { + if (*s == '\n' && s[1] == '\0') { + *s = '\0'; + break; + } else if (*s == '\\' && !seenspace) { + continue; /* Allow backslashes in names */ + } else if (*s == '>' && s >= cmd + 3 + && s[-1] == '2' && s[1] == '&' && s[2] == '1' + && isSPACE(s[-2]) ) { + char *t = s + 3; + + while (*t && isSPACE(*t)) + t++; + if (!*t) { + s[-2] = '\0'; + mergestderr = 1; + break; /* Allow 2>&1 as the last thing */ + } + } + /* We do not convert this to do_spawn_ve since shell + should be smart enough to start itself gloriously. */ + doshell: + if (execf == EXECF_TRUEEXEC) rc = execl(shell,shell,copt,cmd,(char*)0); - else if (execf == EXECF_EXEC) + else if (execf == EXECF_EXEC) rc = spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); - else if (execf == EXECF_SPAWN_NOWAIT) + else if (execf == EXECF_SPAWN_NOWAIT) rc = spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0); - else if (execf == EXECF_SPAWN_BYFLAG) + else if (execf == EXECF_SPAWN_BYFLAG) rc = spawnl(flag,shell,shell,copt,cmd,(char*)0); - else { - /* In the ak code internal P_NOWAIT is P_WAIT ??? */ - if (execf == EXECF_SYNC) - rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0); - else - rc = result(aTHX_ P_WAIT, - spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); - if (rc < 0 && ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s", - (execf == EXECF_SPAWN ? "spawn" : "exec"), - shell, Strerror(errno)); - if (rc < 0) - rc = -1; - } - if (news) - Safefree(news); - goto leave; - } else if (*s == ' ' || *s == '\t') { - seenspace = 1; - } + else { + /* In the ak code internal P_NOWAIT is P_WAIT ??? */ + if (execf == EXECF_SYNC) + rc = spawnl(P_WAIT,shell,shell,copt,cmd,(char*)0); + else + rc = result(aTHX_ P_WAIT, + spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s", + (execf == EXECF_SPAWN ? "spawn" : "exec"), + shell, Strerror(errno)); + if (rc < 0) + rc = -1; + } + if (news) + Safefree(news); + goto leave; + } else if (*s == ' ' || *s == '\t') { + seenspace = 1; + } } /* cmd="a" may lead to "sh", "-c", "\"$@\"", "a", "a.cmd", NULL */ @@ -1458,20 +1458,20 @@ do_spawn3(pTHX_ char *cmd, int execf, int flag) SAVEFREEPV(cmd); a = argv; for (s = cmd; *s;) { - while (*s && isSPACE(*s)) s++; - if (*s) - *(a++) = s; - while (*s && !isSPACE(*s)) s++; - if (*s) - *s++ = '\0'; + while (*s && isSPACE(*s)) s++; + if (*s) + *(a++) = s; + while (*s && !isSPACE(*s)) s++; + if (*s) + *s++ = '\0'; } *a = NULL; if (argv[0]) - rc = do_spawn_ve(aTHX_ NULL, argv, flag, execf, cmd, mergestderr); + rc = do_spawn_ve(aTHX_ NULL, argv, flag, execf, cmd, mergestderr); else - rc = -1; + rc = -1; if (news) - Safefree(news); + Safefree(news); leave: LEAVE; return rc; @@ -1494,37 +1494,37 @@ os2_aspawn_4(pTHX_ SV *really, SV **args, I32 cnt, int execing) ENTER; if (cnt) { - Newx(argv, cnt + 3, char*); /* 3 extra to expand #! */ - SAVEFREEPV(argv); - a = argv; - - if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) { - flag = SvIVx(*argp); - flag_set = 1; - } else - --argp; - - while (++argp < last) { - if (*argp) { - char *arg = SvPVx(*argp, n_a); - arg = savepv(arg); - SAVEFREEPV(arg); - *a++ = arg; - } else - *a++ = ""; - } - *a = NULL; - - if ( flag_set && (a == argv + 1) - && !really && execing == ASPAWN_WAIT ) { /* One arg? */ - rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag); - } else { - const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT}; - - rc = do_spawn_ve(aTHX_ really, argv, flag, execf[execing], NULL, 0); - } + Newx(argv, cnt + 3, char*); /* 3 extra to expand #! */ + SAVEFREEPV(argv); + a = argv; + + if (cnt > 1 && SvNIOKp(*argp) && !SvPOKp(*argp)) { + flag = SvIVx(*argp); + flag_set = 1; + } else + --argp; + + while (++argp < last) { + if (*argp) { + char *arg = SvPVx(*argp, n_a); + arg = savepv(arg); + SAVEFREEPV(arg); + *a++ = arg; + } else + *a++ = ""; + } + *a = NULL; + + if ( flag_set && (a == argv + 1) + && !really && execing == ASPAWN_WAIT ) { /* One arg? */ + rc = do_spawn3(aTHX_ a[-1], EXECF_SPAWN_BYFLAG, flag); + } else { + const int execf[3] = {EXECF_SPAWN, EXECF_EXEC, EXECF_SPAWN_NOWAIT}; + + rc = do_spawn_ve(aTHX_ really, argv, flag, execf[execing], NULL, 0); + } } else - rc = -1; + rc = -1; LEAVE; return rc; } @@ -1582,63 +1582,63 @@ my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args) this = (*mode == 'w'); that = !this; if (TAINTING_get) { - taint_env(); - taint_proper("Insecure %s%s", "EXEC"); + taint_env(); + taint_proper("Insecure %s%s", "EXEC"); } if (pipe(p) < 0) - return NULL; + return NULL; /* Now we need to spawn the child. */ if (p[this] == (*mode == 'r')) { /* if fh 0/1 was initially closed. */ - int new = dup(p[this]); + int new = dup(p[this]); - if (new == -1) - goto closepipes; - close(p[this]); - p[this] = new; + if (new == -1) + goto closepipes; + close(p[this]); + p[this] = new; } newfd = dup(*mode == 'r'); /* Preserve std* */ if (newfd == -1) { - /* This cannot happen due to fh being bad after pipe(), since - pipe() should have created fh 0 and 1 even if they were - initially closed. But we closed p[this] before. */ - if (errno != EBADF) { - closepipes: - close(p[0]); - close(p[1]); - return NULL; - } + /* This cannot happen due to fh being bad after pipe(), since + pipe() should have created fh 0 and 1 even if they were + initially closed. But we closed p[this] before. */ + if (errno != EBADF) { + closepipes: + close(p[0]); + close(p[1]); + return NULL; + } } else - fh_fl = fcntl(*mode == 'r', F_GETFD); + fh_fl = fcntl(*mode == 'r', F_GETFD); if (p[that] != (*mode == 'r')) { /* if fh 0/1 was initially closed. */ - dup2(p[that], *mode == 'r'); - close(p[that]); + dup2(p[that], *mode == 'r'); + close(p[that]); } /* Where is `this' and newfd now? */ fcntl(p[this], F_SETFD, FD_CLOEXEC); if (newfd != -1) - fcntl(newfd, F_SETFD, FD_CLOEXEC); + fcntl(newfd, F_SETFD, FD_CLOEXEC); if (cnt) { /* Args: "Real cmd", before first arg, the last, execing */ - pid = os2_aspawn_4(aTHX_ NULL, args, cnt, ASPAWN_NOWAIT); + pid = os2_aspawn_4(aTHX_ NULL, args, cnt, ASPAWN_NOWAIT); } else - pid = do_spawn_nowait(aTHX_ cmd); + pid = do_spawn_nowait(aTHX_ cmd); if (newfd == -1) - close(*mode == 'r'); /* It was closed initially */ + close(*mode == 'r'); /* It was closed initially */ else if (newfd != (*mode == 'r')) { /* Probably this check is not needed */ - dup2(newfd, *mode == 'r'); /* Return std* back. */ - close(newfd); - fcntl(*mode == 'r', F_SETFD, fh_fl); + dup2(newfd, *mode == 'r'); /* Return std* back. */ + close(newfd); + fcntl(*mode == 'r', F_SETFD, fh_fl); } else - fcntl(*mode == 'r', F_SETFD, fh_fl); + fcntl(*mode == 'r', F_SETFD, fh_fl); if (p[that] == (*mode == 'r')) - close(p[that]); + close(p[that]); if (pid == -1) { - close(p[this]); - return NULL; + close(p[this]); + return NULL; } if (p[that] < p[this]) { /* Make fh as small as possible */ - dup2(p[this], p[that]); - close(p[this]); - p[this] = p[that]; + dup2(p[this], p[that]); + close(p[this]); + p[this] = p[that]; } sv = *av_fetch(PL_fdpid,p[this],TRUE); (void)SvUPGRADE(sv,SVt_IV); @@ -1652,7 +1652,7 @@ my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args) SV *sv; if (cnt) - Perl_croak(aTHX_ "List form of piped open not implemented"); + Perl_croak(aTHX_ "List form of piped open not implemented"); # ifdef TRYSHELL res = popen(cmd, mode); @@ -1726,16 +1726,16 @@ static void massage_os2_attr(struct stat *st) { if ( ((st->st_mode & S_IFMT) != S_IFREG - && (st->st_mode & S_IFMT) != S_IFDIR) + && (st->st_mode & S_IFMT) != S_IFDIR) || !(st->st_attr & (FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM))) - return; + return; if ( st->st_attr & FILE_ARCHIVED ) - st->st_mode |= (os2_stat_archived | os2_stat_force); + st->st_mode |= (os2_stat_archived | os2_stat_force); if ( st->st_attr & FILE_HIDDEN ) - st->st_mode |= (os2_stat_hidden | os2_stat_force); + st->st_mode |= (os2_stat_hidden | os2_stat_force); if ( st->st_attr & FILE_SYSTEM ) - st->st_mode |= (os2_stat_system | os2_stat_force); + st->st_mode |= (os2_stat_system | os2_stat_force); } /* First attempt used DosQueryFSAttach which crashed the system when @@ -1748,15 +1748,15 @@ os2_stat(const char *name, struct stat *st) if ( ( l < 8 || l > 9) || strnicmp(name, "/dev/", 5) != 0 || ( stricmp(name + 5, "con") != 0 - && stricmp(name + 5, "tty") != 0 - && stricmp(name + 5, "nul") != 0 - && stricmp(name + 5, "null") != 0) ) { - int s = stat(name, st); - - if (s) - return s; - massage_os2_attr(st); - return 0; + && stricmp(name + 5, "tty") != 0 + && stricmp(name + 5, "nul") != 0 + && stricmp(name + 5, "null") != 0) ) { + int s = stat(name, st); + + if (s) + return s; + massage_os2_attr(st); + return 0; } memset(st, 0, sizeof *st); @@ -1774,7 +1774,7 @@ os2_fstat(int handle, struct stat *st) int s = fstat(handle, st); if (s) - return s; + return s; massage_os2_attr(st); return 0; } @@ -1786,15 +1786,15 @@ os2_chmod (const char *name, int pmode) /* Modelled after EMX src/lib/io/chmod.c int attr, rc; if (!(pmode & os2_stat_force)) - return chmod(name, pmode); + return chmod(name, pmode); attr = __chmod (name, 0, 0); /* Get attributes */ if (attr < 0) - return -1; + return -1; if (pmode & S_IWRITE) - attr &= ~FILE_READONLY; + attr &= ~FILE_READONLY; else - attr |= FILE_READONLY; + attr |= FILE_READONLY; /* New logic */ attr &= ~(FILE_ARCHIVED | FILE_HIDDEN | FILE_SYSTEM); @@ -1822,9 +1822,9 @@ sys_alloc(int size) { APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); if (rc == ERROR_NOT_ENOUGH_MEMORY) { - return (void *) -1; + return (void *) -1; } else if ( rc ) - Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc); + Perl_croak_nocontext("Got an error from DosAllocMem: %li", (long)rc); return got; } @@ -1846,10 +1846,10 @@ settmppath() len = strlen(p); tpath = (char *)malloc(len + strlen(TMPPATH1) + 2); if (tpath) { - strcpy(tpath, p); - tpath[len] = '/'; - strcpy(tpath + len + 1, TMPPATH1); - tmppath = tpath; + strcpy(tpath, p); + tpath[len] = '/'; + strcpy(tpath + len + 1, TMPPATH1); + tmppath = tpath; } } @@ -1859,23 +1859,23 @@ XS(XS_File__Copy_syscopy) { dXSARGS; if (items < 2 || items > 3) - Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)"); + Perl_croak_nocontext("Usage: File::Copy::syscopy(src,dst,flag=0)"); { - STRLEN n_a; - char * src = (char *)SvPV(ST(0),n_a); - char * dst = (char *)SvPV(ST(1),n_a); - U32 flag; - int RETVAL, rc; - dXSTARG; - - if (items < 3) - flag = 0; - else { - flag = (unsigned long)SvIV(ST(2)); - } - - RETVAL = !CheckOSError(DosCopy(src, dst, flag)); - XSprePUSH; PUSHi((IV)RETVAL); + STRLEN n_a; + char * src = (char *)SvPV(ST(0),n_a); + char * dst = (char *)SvPV(ST(1),n_a); + U32 flag; + int RETVAL, rc; + dXSTARG; + + if (items < 3) + flag = 0; + else { + flag = (unsigned long)SvIV(ST(2)); + } + + RETVAL = !CheckOSError(DosCopy(src, dst, flag)); + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -1883,21 +1883,21 @@ XS(XS_File__Copy_syscopy) /* APIRET APIENTRY DosReplaceModule (PCSZ pszOld, PCSZ pszNew, PCSZ pszBackup); */ DeclOSFuncByORD(ULONG,replaceModule,ORD_DosReplaceModule, - (char *old, char *new, char *backup), (old, new, backup)) + (char *old, char *new, char *backup), (old, new, backup)) XS(XS_OS2_replaceModule); /* prototype to pass -Wmissing-prototypes */ XS(XS_OS2_replaceModule) { dXSARGS; if (items < 1 || items > 3) - Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])"); + Perl_croak(aTHX_ "Usage: OS2::replaceModule(target [, source [, backup]])"); { - char * target = (char *)SvPV_nolen(ST(0)); - char * source = (items < 2) ? NULL : (char *)SvPV_nolen(ST(1)); - char * backup = (items < 3) ? NULL : (char *)SvPV_nolen(ST(2)); + char * target = (char *)SvPV_nolen(ST(0)); + char * source = (items < 2) ? NULL : (char *)SvPV_nolen(ST(1)); + char * backup = (items < 3) ? NULL : (char *)SvPV_nolen(ST(2)); - if (!replaceModule(target, source, backup)) - croak_with_os2error("replaceModule() error"); + if (!replaceModule(target, source, backup)) + croak_with_os2error("replaceModule() error"); } XSRETURN_YES; } @@ -1906,8 +1906,8 @@ XS(XS_OS2_replaceModule) ULONG ulParm2, ULONG ulParm3); */ DeclOSFuncByORD(ULONG,perfSysCall,ORD_DosPerfSysCall, - (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3), - (ulCommand, ulParm1, ulParm2, ulParm3)) + (ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3), + (ulCommand, ulParm1, ulParm2, ulParm3)) #ifndef CMD_KI_RDCNT # define CMD_KI_RDCNT 0x63 @@ -1925,10 +1925,10 @@ typedef unsigned long long myCPUUTIL[4]; /* time/idle/busy/intr */ NO_OUTPUT ULONG perfSysCall(ULONG ulCommand, ULONG ulParm1, ULONG ulParm2, ULONG ulParm3) PREINIT: - ULONG rc; + ULONG rc; POSTCALL: - if (!RETVAL) - croak_with_os2error("perfSysCall() error"); + if (!RETVAL) + croak_with_os2error("perfSysCall() error"); */ static int @@ -1937,7 +1937,7 @@ numprocessors(void) ULONG res; if (DosQuerySysInfo(QSV_NUMPROCESSORS, QSV_NUMPROCESSORS, (PVOID)&res, sizeof(res))) - return 1; /* Old system? */ + return 1; /* Old system? */ return res; } @@ -1946,64 +1946,64 @@ XS(XS_OS2_perfSysCall) { dXSARGS; if (items < 0 || items > 4) - Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)"); + Perl_croak(aTHX_ "Usage: OS2::perfSysCall(ulCommand = CMD_KI_RDCNT, ulParm1= 0, ulParm2= 0, ulParm3= 0)"); SP -= items; { - dXSTARG; - ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res; - myCPUUTIL u[64]; - int total = 0, tot2 = 0; - - if (items < 1) - ulCommand = CMD_KI_RDCNT; - else { - ulCommand = (ULONG)SvUV(ST(0)); - } - - if (items < 2) { - total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0); - ulParm1 = (total ? (ULONG)u : 0); - - if (total > C_ARRAY_LENGTH(u)) - croak("Unexpected number of processors: %d", total); - } else { - ulParm1 = (ULONG)SvUV(ST(1)); - } - - if (items < 3) { - tot2 = (ulCommand == CMD_KI_GETQTY); - ulParm2 = (tot2 ? (ULONG)&res : 0); - } else { - ulParm2 = (ULONG)SvUV(ST(2)); - } - - if (items < 4) - ulParm3 = 0; - else { - ulParm3 = (ULONG)SvUV(ST(3)); - } - - RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3); - if (!RETVAL) - croak_with_os2error("perfSysCall() error"); - XSprePUSH; - if (total) { - int i,j; - - if (GIMME_V != G_ARRAY) { - PUSHn(u[0][0]); /* Total ticks on the first processor */ - XSRETURN(1); - } - EXTEND(SP, 4*total); - for (i=0; i < total; i++) - for (j=0; j < 4; j++) - PUSHs(sv_2mortal(newSVnv(u[i][j]))); - XSRETURN(4*total); - } - if (tot2) { - PUSHu(res); - XSRETURN(1); - } + dXSTARG; + ULONG RETVAL, ulCommand, ulParm1, ulParm2, ulParm3, res; + myCPUUTIL u[64]; + int total = 0, tot2 = 0; + + if (items < 1) + ulCommand = CMD_KI_RDCNT; + else { + ulCommand = (ULONG)SvUV(ST(0)); + } + + if (items < 2) { + total = (ulCommand == CMD_KI_RDCNT ? numprocessors() : 0); + ulParm1 = (total ? (ULONG)u : 0); + + if (total > C_ARRAY_LENGTH(u)) + croak("Unexpected number of processors: %d", total); + } else { + ulParm1 = (ULONG)SvUV(ST(1)); + } + + if (items < 3) { + tot2 = (ulCommand == CMD_KI_GETQTY); + ulParm2 = (tot2 ? (ULONG)&res : 0); + } else { + ulParm2 = (ULONG)SvUV(ST(2)); + } + + if (items < 4) + ulParm3 = 0; + else { + ulParm3 = (ULONG)SvUV(ST(3)); + } + + RETVAL = perfSysCall(ulCommand, ulParm1, ulParm2, ulParm3); + if (!RETVAL) + croak_with_os2error("perfSysCall() error"); + XSprePUSH; + if (total) { + int i,j; + + if (GIMME_V != G_ARRAY) { + PUSHn(u[0][0]); /* Total ticks on the first processor */ + XSRETURN(1); + } + EXTEND(SP, 4*total); + for (i=0; i < total; i++) + for (j=0; j < 4; j++) + PUSHs(sv_2mortal(newSVnv(u[i][j]))); + XSRETURN(4*total); + } + if (tot2) { + PUSHu(res); + XSRETURN(1); + } } XSRETURN_EMPTY; } @@ -2034,15 +2034,15 @@ mod2fname(pTHX_ SV *sv) len = strlen(s); if (len < 6) pos = len; while (*s) { - sum = 33 * sum + *(s++); /* Checksumming first chars to - * get the capitalization into c.s. */ + sum = 33 * sum + *(s++); /* Checksumming first chars to + * get the capitalization into c.s. */ } while (avlen > 0) { - s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); - while (*s) { - sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ - } - avlen --; + s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), n_a); + while (*s) { + sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ + } + avlen --; } /* We always load modules as *specific* DLLs, and with the full name. When loading a specific DLL by its full name, one cannot get a @@ -2066,15 +2066,15 @@ XS(XS_DynaLoader_mod2fname) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)"); + Perl_croak_nocontext("Usage: DynaLoader::mod2fname(sv)"); { - SV * sv = ST(0); - char * RETVAL; - dXSTARG; + SV * sv = ST(0); + char * RETVAL; + dXSTARG; - RETVAL = mod2fname(aTHX_ sv); - sv_setpv(TARG, RETVAL); - XSprePUSH; PUSHTARG; + RETVAL = mod2fname(aTHX_ sv); + sv_setpv(TARG, RETVAL); + XSprePUSH; PUSHTARG; } XSRETURN(1); } @@ -2082,75 +2082,75 @@ XS(XS_DynaLoader_mod2fname) char * os2error(int rc) { - dTHX; - ULONG len; - char *s; - int number = SvTRUE(get_sv("OS2::nsyserror", GV_ADD)); + dTHX; + ULONG len; + char *s; + int number = SvTRUE(get_sv("OS2::nsyserror", GV_ADD)); if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */ - if (rc == 0) - return ""; - if (number) { - sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); - s = os2error_buf + strlen(os2error_buf); - } else - s = os2error_buf; - if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf), - rc, "OSO001.MSG", &len)) { - char *name = ""; - - if (!number) { - sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); - s = os2error_buf + strlen(os2error_buf); - } - switch (rc) { - case PMERR_INVALID_HWND: - name = "PMERR_INVALID_HWND"; - break; - case PMERR_INVALID_HMQ: - name = "PMERR_INVALID_HMQ"; - break; - case PMERR_CALL_FROM_WRONG_THREAD: - name = "PMERR_CALL_FROM_WRONG_THREAD"; - break; - case PMERR_NO_MSG_QUEUE: - name = "PMERR_NO_MSG_QUEUE"; - break; - case PMERR_NOT_IN_A_PM_SESSION: - name = "PMERR_NOT_IN_A_PM_SESSION"; - break; - case PMERR_INVALID_ATOM: - name = "PMERR_INVALID_ATOM"; - break; - case PMERR_INVALID_HATOMTBL: - name = "PMERR_INVALID_HATOMTMB"; - break; - case PMERR_INVALID_INTEGER_ATOM: - name = "PMERR_INVALID_INTEGER_ATOM"; - break; - case PMERR_INVALID_ATOM_NAME: - name = "PMERR_INVALID_ATOM_NAME"; - break; - case PMERR_ATOM_NAME_NOT_FOUND: - name = "PMERR_ATOM_NAME_NOT_FOUND"; - break; - } - sprintf(s, "%s%s[No description found in OSO001.MSG]", - name, (*name ? "=" : "")); - } else { - s[len] = '\0'; - if (len && s[len - 1] == '\n') - s[--len] = 0; - if (len && s[len - 1] == '\r') - s[--len] = 0; - if (len && s[len - 1] == '.') - s[--len] = 0; - if (len >= 10 && number && strnEQ(s, os2error_buf, 7) - && s[7] == ':' && s[8] == ' ') - /* Some messages start with SYSdddd:, some not */ - Move(s + 9, s, (len -= 9) + 1, char); - } - return os2error_buf; + if (rc == 0) + return ""; + if (number) { + sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); + s = os2error_buf + strlen(os2error_buf); + } else + s = os2error_buf; + if (DosGetMessage(NULL, 0, s, sizeof(os2error_buf) - 1 - (s-os2error_buf), + rc, "OSO001.MSG", &len)) { + char *name = ""; + + if (!number) { + sprintf(os2error_buf, "SYS%04d=%#x: ", rc, rc); + s = os2error_buf + strlen(os2error_buf); + } + switch (rc) { + case PMERR_INVALID_HWND: + name = "PMERR_INVALID_HWND"; + break; + case PMERR_INVALID_HMQ: + name = "PMERR_INVALID_HMQ"; + break; + case PMERR_CALL_FROM_WRONG_THREAD: + name = "PMERR_CALL_FROM_WRONG_THREAD"; + break; + case PMERR_NO_MSG_QUEUE: + name = "PMERR_NO_MSG_QUEUE"; + break; + case PMERR_NOT_IN_A_PM_SESSION: + name = "PMERR_NOT_IN_A_PM_SESSION"; + break; + case PMERR_INVALID_ATOM: + name = "PMERR_INVALID_ATOM"; + break; + case PMERR_INVALID_HATOMTBL: + name = "PMERR_INVALID_HATOMTMB"; + break; + case PMERR_INVALID_INTEGER_ATOM: + name = "PMERR_INVALID_INTEGER_ATOM"; + break; + case PMERR_INVALID_ATOM_NAME: + name = "PMERR_INVALID_ATOM_NAME"; + break; + case PMERR_ATOM_NAME_NOT_FOUND: + name = "PMERR_ATOM_NAME_NOT_FOUND"; + break; + } + sprintf(s, "%s%s[No description found in OSO001.MSG]", + name, (*name ? "=" : "")); + } else { + s[len] = '\0'; + if (len && s[len - 1] == '\n') + s[--len] = 0; + if (len && s[len - 1] == '\r') + s[--len] = 0; + if (len && s[len - 1] == '.') + s[--len] = 0; + if (len >= 10 && number && strnEQ(s, os2error_buf, 7) + && s[7] == ':' && s[8] == ' ') + /* Some messages start with SYSdddd:, some not */ + Move(s + 9, s, (len -= 9) + 1, char); + } + return os2error_buf; } void @@ -2196,12 +2196,12 @@ execname2buffer(char *buf, STRLEN l, char *oname) p = buf; while (*p) { if (*p == '\\') - *p = '/'; + *p = '/'; if (*p == '/') { - if (ok && *oname != '/' && *oname != '\\') - ok = 0; + if (ok && *oname != '/' && *oname != '\\') + ok = 0; } else if (ok && tolower(*oname) != tolower(*p)) - ok = 0; + ok = 0; p++; oname++; } @@ -2234,32 +2234,32 @@ Perl_OS2_handler_install(void *handler, enum Perlos2_handler how) switch (how) { case Perlos2_handler_mangle: - perllib_mangle_installed = (char *(*)(char *s, unsigned int l))handler; - return 1; + perllib_mangle_installed = (char *(*)(char *s, unsigned int l))handler; + return 1; case Perlos2_handler_perl_sh: - s = (char *)handler; - s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perl_sh"); - perl_sh_installed = savepv(s); - return 1; + s = (char *)handler; + s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perl_sh"); + perl_sh_installed = savepv(s); + return 1; case Perlos2_handler_perllib_from: - s = (char *)handler; - s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_from"); - oldl = strlen(s); - oldp = savepv(s); - return 1; + s = (char *)handler; + s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_from"); + oldl = strlen(s); + oldp = savepv(s); + return 1; case Perlos2_handler_perllib_to: - s = (char *)handler; - s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_to"); - newl = strlen(s); - newp = savepv(s); - strcpy(mangle_ret, newp); - s = mangle_ret - 1; - while (*++s) - if (*s == '\\') - *s = '/'; - return 1; + s = (char *)handler; + s = dir_subst(s, strlen(s), b, sizeof b, 0, "handler_perllib_to"); + newl = strlen(s); + newp = savepv(s); + strcpy(mangle_ret, newp); + s = mangle_ret - 1; + while (*++s) + if (*s == '\\') + *s = '/'; + return 1; default: - return 0; + return 0; } } @@ -2271,115 +2271,115 @@ dir_subst(char *s, unsigned int l, char *b, unsigned int bl, enum dir_subst_e fl STRLEN froml = 0, tol = 0, rest = 0; /* froml: likewise */ if (l >= 2 && s[0] == '~') { - switch (s[1]) { - case 'i': case 'I': - from = "installprefix"; break; - case 'd': case 'D': - from = "dll"; break; - case 'e': case 'E': - from = "exe"; break; - default: - from = NULL; - froml = l + 1; /* Will not match */ - break; - } - if (from) - froml = strlen(from) + 1; - if (l >= froml && strnicmp(s + 2, from + 1, froml - 2) == 0) { - int strip = 1; - - switch (s[1]) { - case 'i': case 'I': - strip = 0; - tol = strlen(INSTALL_PREFIX); - if (tol >= bl) { - if (flags & dir_subst_fatal) - Perl_croak_nocontext("INSTALL_PREFIX too long: `%s'", INSTALL_PREFIX); - else - return NULL; - } - memcpy(b, INSTALL_PREFIX, tol + 1); - to = b; - e = b + tol; - break; - case 'd': case 'D': - if (flags & dir_subst_fatal) { - dTHX; - - to = dllname2buffer(aTHX_ b, bl); - } else { /* No Perl present yet */ - HMODULE self = find_myself(); - APIRET rc = DosQueryModuleName(self, bl, b); - - if (rc) - return 0; - to = b - 1; - while (*++to) - if (*to == '\\') - *to = '/'; - to = b; - } - break; - case 'e': case 'E': - if (flags & dir_subst_fatal) { - dTHX; - - to = execname2buffer(b, bl, PL_origargv[0]); - } else - to = execname2buffer(b, bl, NULL); - break; - } - if (!to) - return NULL; - if (strip) { - e = strrchr(to, '/'); - if (!e && (flags & dir_subst_fatal)) - Perl_croak_nocontext("%s: Can't parse EXE/DLL name: '%s'", msg, to); - else if (!e) - return NULL; - *e = 0; - } - s += froml; l -= froml; - if (!l) - return to; - if (!tol) - tol = strlen(to); - - while (l >= 3 && (s[0] == '/' || s[0] == '\\') - && s[1] == '.' && s[2] == '.' - && (l == 3 || s[3] == '/' || s[3] == '\\' || s[3] == ';')) { - e = strrchr(b, '/'); - if (!e && (flags & dir_subst_fatal)) - Perl_croak_nocontext("%s: Error stripping dirs from EXE/DLL/INSTALLDIR name", msg); - else if (!e) - return NULL; - *e = 0; - l -= 3; s += 3; - } - if (l && s[0] != '/' && s[0] != '\\' && s[0] != ';') - *e++ = '/'; - } + switch (s[1]) { + case 'i': case 'I': + from = "installprefix"; break; + case 'd': case 'D': + from = "dll"; break; + case 'e': case 'E': + from = "exe"; break; + default: + from = NULL; + froml = l + 1; /* Will not match */ + break; + } + if (from) + froml = strlen(from) + 1; + if (l >= froml && strnicmp(s + 2, from + 1, froml - 2) == 0) { + int strip = 1; + + switch (s[1]) { + case 'i': case 'I': + strip = 0; + tol = strlen(INSTALL_PREFIX); + if (tol >= bl) { + if (flags & dir_subst_fatal) + Perl_croak_nocontext("INSTALL_PREFIX too long: `%s'", INSTALL_PREFIX); + else + return NULL; + } + memcpy(b, INSTALL_PREFIX, tol + 1); + to = b; + e = b + tol; + break; + case 'd': case 'D': + if (flags & dir_subst_fatal) { + dTHX; + + to = dllname2buffer(aTHX_ b, bl); + } else { /* No Perl present yet */ + HMODULE self = find_myself(); + APIRET rc = DosQueryModuleName(self, bl, b); + + if (rc) + return 0; + to = b - 1; + while (*++to) + if (*to == '\\') + *to = '/'; + to = b; + } + break; + case 'e': case 'E': + if (flags & dir_subst_fatal) { + dTHX; + + to = execname2buffer(b, bl, PL_origargv[0]); + } else + to = execname2buffer(b, bl, NULL); + break; + } + if (!to) + return NULL; + if (strip) { + e = strrchr(to, '/'); + if (!e && (flags & dir_subst_fatal)) + Perl_croak_nocontext("%s: Can't parse EXE/DLL name: '%s'", msg, to); + else if (!e) + return NULL; + *e = 0; + } + s += froml; l -= froml; + if (!l) + return to; + if (!tol) + tol = strlen(to); + + while (l >= 3 && (s[0] == '/' || s[0] == '\\') + && s[1] == '.' && s[2] == '.' + && (l == 3 || s[3] == '/' || s[3] == '\\' || s[3] == ';')) { + e = strrchr(b, '/'); + if (!e && (flags & dir_subst_fatal)) + Perl_croak_nocontext("%s: Error stripping dirs from EXE/DLL/INSTALLDIR name", msg); + else if (!e) + return NULL; + *e = 0; + l -= 3; s += 3; + } + if (l && s[0] != '/' && s[0] != '\\' && s[0] != ';') + *e++ = '/'; + } } /* Else: copy as is */ if (l && (flags & dir_subst_pathlike)) { - STRLEN i = 0; - - while ( i < l - 2 && s[i] != ';') /* May have ~char after `;' */ - i++; - if (i < l - 2) { /* Found */ - rest = l - i - 1; - l = i + 1; - } + STRLEN i = 0; + + while ( i < l - 2 && s[i] != ';') /* May have ~char after `;' */ + i++; + if (i < l - 2) { /* Found */ + rest = l - i - 1; + l = i + 1; + } } if (e + l >= b + bl) { - if (flags & dir_subst_fatal) - Perl_croak_nocontext("%s: name `%s%s' too long", msg, b, s); - else - return NULL; + if (flags & dir_subst_fatal) + Perl_croak_nocontext("%s: name `%s%s' too long", msg, b, s); + else + return NULL; } memcpy(e, s, l); if (rest) { - e = dir_subst(s + l, rest, e + l, bl - (e + l - b), flags, msg); - return e ? b : e; + e = dir_subst(s + l, rest, e + l, bl - (e + l - b), flags, msg); + return e ? b : e; } e[l] = 0; return b; @@ -2389,15 +2389,15 @@ char * perllib_mangle_with(char *s, unsigned int l, char *from, unsigned int froml, char *to, unsigned int tol) { if (!to) - return s; + return s; if (l == 0) - l = strlen(s); + l = strlen(s); if (l < froml || strnicmp(from, s, froml) != 0) - return s; + return s; if (l + tol - froml > STATIC_FILE_LENGTH || tol > STATIC_FILE_LENGTH) - Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); + Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); if (to && to != mangle_ret) - memcpy(mangle_ret, to, tol); + memcpy(mangle_ret, to, tol); strcpy(mangle_ret + tol, s + froml); return mangle_ret; } @@ -2408,44 +2408,44 @@ perllib_mangle(char *s, unsigned int l) char *name; if (perllib_mangle_installed && (name = perllib_mangle_installed(s,l))) - return name; + return name; if (!newp && !notfound) { - newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) - STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION) - "_PREFIX"); - if (!newp) - newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) - STRINGIFY(PERL_VERSION) "_PREFIX"); - if (!newp) - newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX"); - if (!newp) - newp = PerlEnv_getenv(name = "PERLLIB_PREFIX"); - if (newp) { - char *s, b[300]; - - oldp = newp; - while (*newp && !isSPACE(*newp) && *newp != ';') - newp++; /* Skip old name. */ - oldl = newp - oldp; - s = dir_subst(oldp, oldl, b, sizeof b, dir_subst_fatal, name); - oldp = savepv(s); - oldl = strlen(s); - while (*newp && (isSPACE(*newp) || *newp == ';')) - newp++; /* Skip whitespace. */ - Perl_OS2_handler_install((void *)newp, Perlos2_handler_perllib_to); - if (newl == 0 || oldl == 0) - Perl_croak_nocontext("Malformed %s", name); - } else - notfound = 1; + newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) + STRINGIFY(PERL_VERSION) STRINGIFY(PERL_SUBVERSION) + "_PREFIX"); + if (!newp) + newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) + STRINGIFY(PERL_VERSION) "_PREFIX"); + if (!newp) + newp = PerlEnv_getenv(name = "PERLLIB_" STRINGIFY(PERL_REVISION) "_PREFIX"); + if (!newp) + newp = PerlEnv_getenv(name = "PERLLIB_PREFIX"); + if (newp) { + char *s, b[300]; + + oldp = newp; + while (*newp && !isSPACE(*newp) && *newp != ';') + newp++; /* Skip old name. */ + oldl = newp - oldp; + s = dir_subst(oldp, oldl, b, sizeof b, dir_subst_fatal, name); + oldp = savepv(s); + oldl = strlen(s); + while (*newp && (isSPACE(*newp) || *newp == ';')) + newp++; /* Skip whitespace. */ + Perl_OS2_handler_install((void *)newp, Perlos2_handler_perllib_to); + if (newl == 0 || oldl == 0) + Perl_croak_nocontext("Malformed %s", name); + } else + notfound = 1; } if (!newp) - return s; + return s; if (l == 0) - l = strlen(s); + l = strlen(s); if (l < oldl || strnicmp(oldp, s, oldl) != 0) - return s; + return s; if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) - Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); + Perl_croak_nocontext("Malformed PERLLIB_PREFIX"); strcpy(mangle_ret + newl, s + oldl); return mangle_ret; } @@ -2465,15 +2465,15 @@ Create_HMQ(int serve, char *message) /* Assumes morphing */ /* 64 messages if before OS/2 3.0, ignored otherwise */ Perl_hmq = (*PMWIN_entries.CreateMsgQueue)(perl_hab_GET(), 64); if (!Perl_hmq) { - dTHX; + dTHX; - SAVEINT(rmq_cnt); /* Allow catch()ing. */ - if (rmq_cnt++) - _exit(188); /* Panic can try to create a window. */ - CroakWinError(1, message ? message : "Cannot create a message queue"); + SAVEINT(rmq_cnt); /* Allow catch()ing. */ + if (rmq_cnt++) + _exit(188); /* Panic can try to create a window. */ + CroakWinError(1, message ? message : "Cannot create a message queue"); } if (serve != -1) - (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve); + (*PMWIN_entries.CancelShutdown)(Perl_hmq, !serve); /* We may have loaded some modules */ _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ } @@ -2491,28 +2491,28 @@ Perl_Register_MQ(int serve) Perl_hmq_refcnt = 0; /* Be extra safe */ DosGetInfoBlocks(&tib, &pib); if (!Perl_morph_refcnt) { - Perl_os2_initial_mode = pib->pib_ultype; - /* Try morphing into a PM application. */ - if (pib->pib_ultype != 3) /* 2 is VIO */ - pib->pib_ultype = 3; /* 3 is PM */ + Perl_os2_initial_mode = pib->pib_ultype; + /* Try morphing into a PM application. */ + if (pib->pib_ultype != 3) /* 2 is VIO */ + pib->pib_ultype = 3; /* 3 is PM */ } Create_HMQ(-1, /* We do CancelShutdown ourselves */ - "Cannot create a message queue, or morph to a PM application"); + "Cannot create a message queue, or morph to a PM application"); if ((serve & REGISTERMQ_IMEDIATE_UNMORPH)) { - if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3) - pib->pib_ultype = Perl_os2_initial_mode; + if (!Perl_morph_refcnt && Perl_os2_initial_mode != 3) + pib->pib_ultype = Perl_os2_initial_mode; } } if (serve & REGISTERMQ_WILL_SERVE) { - if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */ - && Perl_hmq_refcnt > 0 ) /* this was switched off before... */ - (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0); - Perl_hmq_servers++; + if ( Perl_hmq_servers <= 0 /* Safe to inform us on shutdown, */ + && Perl_hmq_refcnt > 0 ) /* this was switched off before... */ + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 0); + Perl_hmq_servers++; } else if (!Perl_hmq_servers) /* Do not inform us on shutdown */ - (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); Perl_hmq_refcnt++; if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH)) - Perl_morph_refcnt++; + Perl_morph_refcnt++; return Perl_hmq; } @@ -2523,14 +2523,14 @@ Perl_Serve_Messages(int force) QMSG msg; if (Perl_hmq_servers > 0 && !force) - return 0; + return 0; if (Perl_hmq_refcnt <= 0) - Perl_croak_nocontext("No message queue"); + Perl_croak_nocontext("No message queue"); while ((*PMWIN_entries.PeekMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0, PM_REMOVE)) { - cnt++; - if (msg.msg == WM_QUIT) - Perl_croak_nocontext("QUITing..."); - (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); + cnt++; + if (msg.msg == WM_QUIT) + Perl_croak_nocontext("QUITing..."); + (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); } return cnt; } @@ -2541,17 +2541,17 @@ Perl_Process_Messages(int force, I32 *cntp) QMSG msg; if (Perl_hmq_servers > 0 && !force) - return 0; + return 0; if (Perl_hmq_refcnt <= 0) - Perl_croak_nocontext("No message queue"); + Perl_croak_nocontext("No message queue"); while ((*PMWIN_entries.GetMsg)(Perl_hab, &msg, NULLHANDLE, 0, 0)) { - if (cntp) - (*cntp)++; - (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); - if (msg.msg == WM_DESTROY) - return -1; - if (msg.msg == WM_CREATE) - return +1; + if (cntp) + (*cntp)++; + (*PMWIN_entries.DispatchMsg)(Perl_hab, &msg); + if (msg.msg == WM_DESTROY) + return -1; + if (msg.msg == WM_CREATE) + return +1; } Perl_croak_nocontext("QUITing..."); } @@ -2560,34 +2560,34 @@ void Perl_Deregister_MQ(int serve) { if (serve & REGISTERMQ_WILL_SERVE) - Perl_hmq_servers--; + Perl_hmq_servers--; if (--Perl_hmq_refcnt <= 0) { - unsigned fpflag = _control87(0,0); + unsigned fpflag = _control87(0,0); - init_PMWIN_entries(); /* To be extra safe */ - (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); - Perl_hmq = 0; - /* We may have (un)loaded some modules */ - _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ + init_PMWIN_entries(); /* To be extra safe */ + (*PMWIN_entries.DestroyMsgQueue)(Perl_hmq); + Perl_hmq = 0; + /* We may have (un)loaded some modules */ + _control87(fpflag, MCW_EM); /* Some modules reset FP flags on (un)load */ } else if ((serve & REGISTERMQ_WILL_SERVE) && Perl_hmq_servers <= 0) - (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */ + (*PMWIN_entries.CancelShutdown)(Perl_hmq, 1); /* Last server exited */ if (!(serve & REGISTERMQ_IMEDIATE_UNMORPH) && (--Perl_morph_refcnt <= 0)) { - /* Try morphing back from a PM application. */ - PPIB pib; - PTIB tib; - - DosGetInfoBlocks(&tib, &pib); - if (pib->pib_ultype == 3) /* 3 is PM */ - pib->pib_ultype = Perl_os2_initial_mode; - else - Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", - pib->pib_ultype); + /* Try morphing back from a PM application. */ + PPIB pib; + PTIB tib; + + DosGetInfoBlocks(&tib, &pib); + if (pib->pib_ultype == 3) /* 3 is PM */ + pib->pib_ultype = Perl_os2_initial_mode; + else + Perl_warn_nocontext("Unexpected program mode %d when morphing back from PM", + pib->pib_ultype); } } #define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \ - && ((path)[2] == '/' || (path)[2] == '\\')) + && ((path)[2] == '/' || (path)[2] == '\\')) #define sys_is_rooted _fnisabs #define sys_is_relative _fnisrel #define current_drive _getdrive @@ -2600,21 +2600,21 @@ XS(XS_OS2_Error) { dXSARGS; if (items != 2) - Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)"); + Perl_croak_nocontext("Usage: OS2::Error(harderr, exception)"); { - int arg1 = SvIV(ST(0)); - int arg2 = SvIV(ST(1)); - int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR) - | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION)); - int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0)); - unsigned long rc; - - if (CheckOSError(DosError(a))) - Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc)); - ST(0) = sv_newmortal(); - if (DOS_harderr_state >= 0) - sv_setiv(ST(0), DOS_harderr_state); - DOS_harderr_state = RETVAL; + int arg1 = SvIV(ST(0)); + int arg2 = SvIV(ST(1)); + int a = ((arg1 ? FERR_ENABLEHARDERR : FERR_DISABLEHARDERR) + | (arg2 ? FERR_ENABLEEXCEPTION : FERR_DISABLEEXCEPTION)); + int RETVAL = ((arg1 ? 1 : 0) | (arg2 ? 2 : 0)); + unsigned long rc; + + if (CheckOSError(DosError(a))) + Perl_croak_nocontext("DosError(%d) failed: %s", a, os2error(Perl_rc)); + ST(0) = sv_newmortal(); + if (DOS_harderr_state >= 0) + sv_setiv(ST(0), DOS_harderr_state); + DOS_harderr_state = RETVAL; } XSRETURN(1); } @@ -2623,29 +2623,29 @@ XS(XS_OS2_Errors2Drive) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)"); + Perl_croak_nocontext("Usage: OS2::Errors2Drive(drive)"); { - STRLEN n_a; - SV *sv = ST(0); - int suppress = SvOK(sv); - char *s = suppress ? SvPV(sv, n_a) : NULL; - char drive = (s ? *s : 0); - unsigned long rc; - - if (suppress && !isALPHA(drive)) - Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive); - if (CheckOSError(DosSuppressPopUps((suppress - ? SPU_ENABLESUPPRESSION - : SPU_DISABLESUPPRESSION), - drive))) - Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive, - os2error(Perl_rc)); - ST(0) = sv_newmortal(); - if (DOS_suppression_state > 0) - sv_setpvn(ST(0), &DOS_suppression_state, 1); - else if (DOS_suppression_state == 0) + STRLEN n_a; + SV *sv = ST(0); + int suppress = SvOK(sv); + char *s = suppress ? SvPV(sv, n_a) : NULL; + char drive = (s ? *s : 0); + unsigned long rc; + + if (suppress && !isALPHA(drive)) + Perl_croak_nocontext("Non-char argument '%c' to OS2::Errors2Drive()", drive); + if (CheckOSError(DosSuppressPopUps((suppress + ? SPU_ENABLESUPPRESSION + : SPU_DISABLESUPPRESSION), + drive))) + Perl_croak_nocontext("DosSuppressPopUps(%c) failed: %s", drive, + os2error(Perl_rc)); + ST(0) = sv_newmortal(); + if (DOS_suppression_state > 0) + sv_setpvn(ST(0), &DOS_suppression_state, 1); + else if (DOS_suppression_state == 0) SvPVCLEAR(ST(0)); - DOS_suppression_state = drive; + DOS_suppression_state = drive; } XSRETURN(1); } @@ -2668,49 +2668,49 @@ async_mssleep(ULONG ms, int switch_priority) { return !_sleep2(ms); os2cp_croak(DosCreateEventSem(NULL, /* Unnamed */ - &hevEvent1, /* Handle of semaphore returned */ - DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */ - FALSE), /* Semaphore is in RESET state */ - "DosCreateEventSem"); + &hevEvent1, /* Handle of semaphore returned */ + DC_SEM_SHARED, /* Shared needed for DosAsyncTimer */ + FALSE), /* Semaphore is in RESET state */ + "DosCreateEventSem"); if (ms >= switch_priority) switch_priority = 0; if (switch_priority) { if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) - switch_priority = 0; + switch_priority = 0; else { - /* In Warp3, to switch scheduling to 8ms step, one needs to do - DosAsyncTimer() in time-critical thread. On laters versions, - more and more cases of wait-for-something are covered. - - It turns out that on Warp3fp42 it is the priority at the time - of DosAsyncTimer() which matters. Let's hope that this works - with later versions too... XXXX - */ - priority = (tib->tib_ptib2->tib2_ulpri); - if ((priority & 0xFF00) == 0x0300) /* already time-critical */ - switch_priority = 0; - /* Make us time-critical. Just modifying TIB is not enough... */ - /* tib->tib_ptib2->tib2_ulpri = 0x0300;*/ - /* We do not want to run at high priority if a signal causes us - to longjmp() out of this section... */ - if (DosEnterMustComplete(&nesting)) - switch_priority = 0; - else - DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0); + /* In Warp3, to switch scheduling to 8ms step, one needs to do + DosAsyncTimer() in time-critical thread. On laters versions, + more and more cases of wait-for-something are covered. + + It turns out that on Warp3fp42 it is the priority at the time + of DosAsyncTimer() which matters. Let's hope that this works + with later versions too... XXXX + */ + priority = (tib->tib_ptib2->tib2_ulpri); + if ((priority & 0xFF00) == 0x0300) /* already time-critical */ + switch_priority = 0; + /* Make us time-critical. Just modifying TIB is not enough... */ + /* tib->tib_ptib2->tib2_ulpri = 0x0300;*/ + /* We do not want to run at high priority if a signal causes us + to longjmp() out of this section... */ + if (DosEnterMustComplete(&nesting)) + switch_priority = 0; + else + DosSetPriority(PRTYS_THREAD, PRTYC_TIMECRITICAL, 0, 0); } } if ((badrc = DosAsyncTimer(ms, - (HSEM) hevEvent1, /* Semaphore to post */ - &htimerEvent1))) /* Timer handler (returned) */ + (HSEM) hevEvent1, /* Semaphore to post */ + &htimerEvent1))) /* Timer handler (returned) */ e = "DosAsyncTimer"; if (switch_priority && tib->tib_ptib2->tib2_ulpri == 0x0300) { - /* Nobody switched priority while we slept... Ignore errors... */ - /* tib->tib_ptib2->tib2_ulpri = priority; */ /* Get back... */ - if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0))) - rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0); + /* Nobody switched priority while we slept... Ignore errors... */ + /* tib->tib_ptib2->tib2_ulpri = priority; */ /* Get back... */ + if (!(rc = DosSetPriority(PRTYS_THREAD, (priority>>8) & 0xFF, 0, 0))) + rc = DosSetPriority(PRTYS_THREAD, 0, priority & 0xFF, 0); } if (switch_priority) rc = DosExitMustComplete(&nesting); /* Ignore errors */ @@ -2742,7 +2742,7 @@ XS(XS_OS2_ms_sleep) /* for testing only... */ ULONG ms, lim; if (items > 2 || items < 1) - Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])"); + Perl_croak_nocontext("Usage: OS2::ms_sleep(wait_ms [, high_priority_limit])"); ms = SvUV(ST(0)); lim = items > 1 ? SvUV(ST(1)) : ms + 1; async_mssleep(ms, lim); @@ -2760,22 +2760,22 @@ XS(XS_OS2_Timer) ULONG rc; if (items != 0) - Perl_croak_nocontext("Usage: OS2::Timer()"); + Perl_croak_nocontext("Usage: OS2::Timer()"); if (!freq) { - *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0); - *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0); - MUTEX_LOCK(&perlos2_state_mutex); - if (!freq) - if (CheckOSError(pDosTmrQueryFreq(&freq))) - croak_with_os2error("DosTmrQueryFreq"); - MUTEX_UNLOCK(&perlos2_state_mutex); + *(PFN*)&pDosTmrQueryFreq = loadByOrdinal(ORD_DosTmrQueryFreq, 0); + *(PFN*)&pDosTmrQueryTime = loadByOrdinal(ORD_DosTmrQueryTime, 0); + MUTEX_LOCK(&perlos2_state_mutex); + if (!freq) + if (CheckOSError(pDosTmrQueryFreq(&freq))) + croak_with_os2error("DosTmrQueryFreq"); + MUTEX_UNLOCK(&perlos2_state_mutex); } if (CheckOSError(pDosTmrQueryTime(&count))) - croak_with_os2error("DosTmrQueryTime"); + croak_with_os2error("DosTmrQueryTime"); { - dXSTARG; + dXSTARG; - XSprePUSH; PUSHn(((NV)count)/freq); + XSprePUSH; PUSHn(((NV)count)/freq); } XSRETURN(1); } @@ -2785,11 +2785,11 @@ XS(XS_OS2_msCounter) dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: OS2::msCounter()"); + Perl_croak_nocontext("Usage: OS2::msCounter()"); { - dXSTARG; + dXSTARG; - XSprePUSH; PUSHu(msCounter()); + XSprePUSH; PUSHu(msCounter()); } XSRETURN(1); } @@ -2800,13 +2800,13 @@ XS(XS_OS2__InfoTable) int is_local = 0; if (items > 1) - Perl_croak_nocontext("Usage: OS2::_infoTable([isLocal])"); + Perl_croak_nocontext("Usage: OS2::_infoTable([isLocal])"); if (items == 1) - is_local = (int)SvIV(ST(0)); + is_local = (int)SvIV(ST(0)); { - dXSTARG; + dXSTARG; - XSprePUSH; PUSHu(InfoTable(is_local)); + XSprePUSH; PUSHu(InfoTable(is_local)); } XSRETURN(1); } @@ -2871,76 +2871,76 @@ XS(XS_OS2_DevCap) { dXSARGS; if (items > 2) - Perl_croak_nocontext("Usage: OS2::DevCap()"); + Perl_croak_nocontext("Usage: OS2::DevCap()"); { - /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */ - LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1]; - int i = 0, j = 0, how = DevCap_dc; - HDC hScreenDC; - DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L}; - ULONG rc1 = NO_ERROR; - HWND hwnd; - static volatile int devcap_loaded; - - if (!devcap_loaded) { - *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0); - *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0); - *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0); - *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0); - devcap_loaded = 1; - } - - if (items >= 2) - how = SvIV(ST(1)); - if (!items) { /* Get device contents from PM */ - hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0, - (PDEVOPENDATA)&doStruc, NULLHANDLE); - if (CheckWinError(hScreenDC)) - croak_with_os2error("DevOpenDC() failed"); - } else if (how == DevCap_dc) - hScreenDC = (HDC)SvIV(ST(0)); - else { /* DevCap_hwnd */ - if (!Perl_hmq) - Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM"); - hwnd = (HWND)SvIV(ST(0)); - hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */ - if (CheckWinError(hScreenDC)) - croak_with_os2error("WinOpenWindowDC() failed"); - } - if (CheckWinError(pDevQueryCaps(hScreenDC, - CAPS_FAMILY, /* W3 documented caps */ - CAPS_DEVICE_POLYSET_POINTS - - CAPS_FAMILY + 1, - si))) - rc1 = Perl_rc; - else { - EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1)); - while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) { - ST(j) = sv_newmortal(); - sv_setpv(ST(j++), dc_fields[i]); - ST(j) = sv_newmortal(); - sv_setiv(ST(j++), si[i]); - i++; - } - i = CAPS_DEVICE_POLYSET_POINTS + 1; - while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */ - LONG l; - - if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l))) - break; - EXTEND(SP, j + 2); - ST(j) = sv_newmortal(); - sv_setiv(ST(j++), i); - ST(j) = sv_newmortal(); - sv_setiv(ST(j++), l); - i++; - } - } - if (!items && CheckWinError(pDevCloseDC(hScreenDC))) - Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc)); - if (rc1) - Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed"); - XSRETURN(j); + /* Device Capabilities Data Buffer (10 extra w.r.t. Warp 4.5) */ + LONG si[CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1]; + int i = 0, j = 0, how = DevCap_dc; + HDC hScreenDC; + DEVOPENSTRUC doStruc= {0L, (PSZ)"DISPLAY", NULL, 0L, 0L, 0L, 0L, 0L, 0L}; + ULONG rc1 = NO_ERROR; + HWND hwnd; + static volatile int devcap_loaded; + + if (!devcap_loaded) { + *(PFN*)&pWinOpenWindowDC = loadByOrdinal(ORD_WinOpenWindowDC, 0); + *(PFN*)&pDevOpenDC = loadByOrdinal(ORD_DevOpenDC, 0); + *(PFN*)&pDevCloseDC = loadByOrdinal(ORD_DevCloseDC, 0); + *(PFN*)&pDevQueryCaps = loadByOrdinal(ORD_DevQueryCaps, 0); + devcap_loaded = 1; + } + + if (items >= 2) + how = SvIV(ST(1)); + if (!items) { /* Get device contents from PM */ + hScreenDC = pDevOpenDC(perl_hab_GET(), OD_MEMORY, (PSZ)"*", 0, + (PDEVOPENDATA)&doStruc, NULLHANDLE); + if (CheckWinError(hScreenDC)) + croak_with_os2error("DevOpenDC() failed"); + } else if (how == DevCap_dc) + hScreenDC = (HDC)SvIV(ST(0)); + else { /* DevCap_hwnd */ + if (!Perl_hmq) + Perl_croak(aTHX_ "Getting a window's device context without a message queue would lock PM"); + hwnd = (HWND)SvIV(ST(0)); + hScreenDC = pWinOpenWindowDC(hwnd); /* No need to DevCloseDC() */ + if (CheckWinError(hScreenDC)) + croak_with_os2error("WinOpenWindowDC() failed"); + } + if (CheckWinError(pDevQueryCaps(hScreenDC, + CAPS_FAMILY, /* W3 documented caps */ + CAPS_DEVICE_POLYSET_POINTS + - CAPS_FAMILY + 1, + si))) + rc1 = Perl_rc; + else { + EXTEND(SP,2*(CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1)); + while (i < CAPS_DEVICE_POLYSET_POINTS - CAPS_FAMILY + 1) { + ST(j) = sv_newmortal(); + sv_setpv(ST(j++), dc_fields[i]); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), si[i]); + i++; + } + i = CAPS_DEVICE_POLYSET_POINTS + 1; + while (i < CAPS_DEVICE_POLYSET_POINTS + 11) { /* Just in case... */ + LONG l; + + if (CheckWinError(pDevQueryCaps(hScreenDC, i, 1, &l))) + break; + EXTEND(SP, j + 2); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), i); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), l); + i++; + } + } + if (!items && CheckWinError(pDevCloseDC(hScreenDC))) + Perl_warn_nocontext("DevCloseDC() failed: %s", os2error(Perl_rc)); + if (rc1) + Perl_rc = rc1, croak_with_os2error("DevQueryCaps() failed"); + XSRETURN(j); } } @@ -3057,64 +3057,64 @@ const char * const sv_keys[] = { "106", "107", /* "CSYSVALUES",*/ - /* In recent DDK the limit is 108 */ + /* In recent DDK the limit is 108 */ }; XS(XS_OS2_SysValues) { dXSARGS; if (items > 2) - Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)"); + Perl_croak_nocontext("Usage: OS2::SysValues(which = -1, hwndDesktop = HWND_DESKTOP)"); { - int i = 0, j = 0, which = -1; - HWND hwnd = HWND_DESKTOP; - static volatile int sv_loaded; - LONG RETVAL; - - if (!sv_loaded) { - *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0); - sv_loaded = 1; - } - - if (items == 2) - hwnd = (HWND)SvIV(ST(1)); - if (items >= 1) - which = (int)SvIV(ST(0)); - if (which == -1) { - EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys)); - while (i < C_ARRAY_LENGTH(sv_keys)) { - ResetWinError(); - RETVAL = pWinQuerySysValue(hwnd, i); - if ( !RETVAL - && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9' - && i <= SV_PRINTSCREEN) ) { - FillWinError; - if (Perl_rc) { - if (i > SV_PRINTSCREEN) - break; /* May be not present on older systems */ - croak_with_os2error("SysValues():"); - } - - } - ST(j) = sv_newmortal(); - sv_setpv(ST(j++), sv_keys[i]); - ST(j) = sv_newmortal(); - sv_setiv(ST(j++), RETVAL); - i++; - } - XSRETURN(2 * i); - } else { - dXSTARG; - - ResetWinError(); - RETVAL = pWinQuerySysValue(hwnd, which); - if (!RETVAL) { - FillWinError; - if (Perl_rc) - croak_with_os2error("SysValues():"); - } - XSprePUSH; PUSHi((IV)RETVAL); - } + int i = 0, j = 0, which = -1; + HWND hwnd = HWND_DESKTOP; + static volatile int sv_loaded; + LONG RETVAL; + + if (!sv_loaded) { + *(PFN*)&pWinQuerySysValue = loadByOrdinal(ORD_WinQuerySysValue, 0); + sv_loaded = 1; + } + + if (items == 2) + hwnd = (HWND)SvIV(ST(1)); + if (items >= 1) + which = (int)SvIV(ST(0)); + if (which == -1) { + EXTEND(SP,2*C_ARRAY_LENGTH(sv_keys)); + while (i < C_ARRAY_LENGTH(sv_keys)) { + ResetWinError(); + RETVAL = pWinQuerySysValue(hwnd, i); + if ( !RETVAL + && !(sv_keys[i][0] >= '0' && sv_keys[i][0] <= '9' + && i <= SV_PRINTSCREEN) ) { + FillWinError; + if (Perl_rc) { + if (i > SV_PRINTSCREEN) + break; /* May be not present on older systems */ + croak_with_os2error("SysValues():"); + } + + } + ST(j) = sv_newmortal(); + sv_setpv(ST(j++), sv_keys[i]); + ST(j) = sv_newmortal(); + sv_setiv(ST(j++), RETVAL); + i++; + } + XSRETURN(2 * i); + } else { + dXSTARG; + + ResetWinError(); + RETVAL = pWinQuerySysValue(hwnd, which); + if (!RETVAL) { + FillWinError; + if (Perl_rc) + croak_with_os2error("SysValues():"); + } + XSprePUSH; PUSHi((IV)RETVAL); + } } } @@ -3122,22 +3122,22 @@ XS(XS_OS2_SysValues_set) { dXSARGS; if (items < 2 || items > 3) - Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)"); + Perl_croak_nocontext("Usage: OS2::SysValues_set(which, val, hwndDesktop = HWND_DESKTOP)"); { - int which = (int)SvIV(ST(0)); - LONG val = (LONG)SvIV(ST(1)); - HWND hwnd = HWND_DESKTOP; - static volatile int svs_loaded; - - if (!svs_loaded) { - *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0); - svs_loaded = 1; - } - - if (items == 3) - hwnd = (HWND)SvIV(ST(2)); - if (CheckWinError(pWinSetSysValue(hwnd, which, val))) - croak_with_os2error("SysValues_set()"); + int which = (int)SvIV(ST(0)); + LONG val = (LONG)SvIV(ST(1)); + HWND hwnd = HWND_DESKTOP; + static volatile int svs_loaded; + + if (!svs_loaded) { + *(PFN*)&pWinSetSysValue = loadByOrdinal(ORD_WinSetSysValue, 0); + svs_loaded = 1; + } + + if (items == 3) + hwnd = (HWND)SvIV(ST(2)); + if (CheckWinError(pWinSetSysValue(hwnd, which, val))) + croak_with_os2error("SysValues_set()"); } XSRETURN_YES; } @@ -3182,40 +3182,40 @@ XS(XS_OS2_SysInfo) { dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: OS2::SysInfo()"); + Perl_croak_nocontext("Usage: OS2::SysInfo()"); { - /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ - ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; - APIRET rc = NO_ERROR; /* Return code */ - int i = 0, j = 0, last = QSV_MAX_WARP3; - - if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */ - last, /* info for Warp 3 */ - (PVOID)si, - sizeof(si)))) - croak_with_os2error("DosQuerySysInfo() failed"); - while (++last <= C_ARRAY_LENGTH(si)) { - if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */ - (PVOID)(si+last-1), - sizeof(*si)))) { - if (Perl_rc != ERROR_INVALID_PARAMETER) - croak_with_os2error("DosQuerySysInfo() failed"); - break; - } - } - last--; /* Count of successfully processed offsets */ - EXTEND(SP,2*last); - while (i < last) { - ST(j) = sv_newmortal(); - if (i < C_ARRAY_LENGTH(si_fields)) - sv_setpv(ST(j++), si_fields[i]); - else - sv_setiv(ST(j++), i + 1); - ST(j) = sv_newmortal(); - sv_setuv(ST(j++), si[i]); - i++; - } - XSRETURN(2 * last); + /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ + ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; + APIRET rc = NO_ERROR; /* Return code */ + int i = 0, j = 0, last = QSV_MAX_WARP3; + + if (CheckOSError(DosQuerySysInfo(1L, /* Request documented system */ + last, /* info for Warp 3 */ + (PVOID)si, + sizeof(si)))) + croak_with_os2error("DosQuerySysInfo() failed"); + while (++last <= C_ARRAY_LENGTH(si)) { + if (CheckOSError(DosQuerySysInfo(last, last, /* One entry only */ + (PVOID)(si+last-1), + sizeof(*si)))) { + if (Perl_rc != ERROR_INVALID_PARAMETER) + croak_with_os2error("DosQuerySysInfo() failed"); + break; + } + } + last--; /* Count of successfully processed offsets */ + EXTEND(SP,2*last); + while (i < last) { + ST(j) = sv_newmortal(); + if (i < C_ARRAY_LENGTH(si_fields)) + sv_setpv(ST(j++), si_fields[i]); + else + sv_setiv(ST(j++), i + 1); + ST(j) = sv_newmortal(); + sv_setuv(ST(j++), si[i]); + i++; + } + XSRETURN(2 * last); } } @@ -3225,27 +3225,27 @@ XS(XS_OS2_SysInfoFor) int count = (items == 2 ? (int)SvIV(ST(1)) : 1); if (items < 1 || items > 2) - Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])"); + Perl_croak_nocontext("Usage: OS2::SysInfoFor(id[,count])"); { - /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ - ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; - APIRET rc = NO_ERROR; /* Return code */ - int i = 0; - int start = (int)SvIV(ST(0)); - - if (count > C_ARRAY_LENGTH(si) || count <= 0) - Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count); - if (CheckOSError(DosQuerySysInfo(start, - start + count - 1, - (PVOID)si, - sizeof(si)))) - croak_with_os2error("DosQuerySysInfo() failed"); - EXTEND(SP,count); - while (i < count) { - ST(i) = sv_newmortal(); - sv_setiv(ST(i), si[i]); - i++; - } + /* System Information Data Buffer (10 extra w.r.t. Warp 4.5) */ + ULONG si[C_ARRAY_LENGTH(si_fields) + 10]; + APIRET rc = NO_ERROR; /* Return code */ + int i = 0; + int start = (int)SvIV(ST(0)); + + if (count > C_ARRAY_LENGTH(si) || count <= 0) + Perl_croak(aTHX_ "unexpected count %d for OS2::SysInfoFor()", count); + if (CheckOSError(DosQuerySysInfo(start, + start + count - 1, + (PVOID)si, + sizeof(si)))) + croak_with_os2error("DosQuerySysInfo() failed"); + EXTEND(SP,count); + while (i < count) { + ST(i) = sv_newmortal(); + sv_setiv(ST(i), si[i]); + i++; + } } XSRETURN(count); } @@ -3254,19 +3254,19 @@ XS(XS_OS2_BootDrive) { dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: OS2::BootDrive()"); + Perl_croak_nocontext("Usage: OS2::BootDrive()"); { - ULONG si[1] = {0}; /* System Information Data Buffer */ - APIRET rc = NO_ERROR; /* Return code */ - char c; - dXSTARG; - - if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, - (PVOID)si, sizeof(si)))) - croak_with_os2error("DosQuerySysInfo() failed"); - c = 'a' - 1 + si[0]; - sv_setpvn(TARG, &c, 1); - XSprePUSH; PUSHTARG; + ULONG si[1] = {0}; /* System Information Data Buffer */ + APIRET rc = NO_ERROR; /* Return code */ + char c; + dXSTARG; + + if (CheckOSError(DosQuerySysInfo(QSV_BOOT_DRIVE, QSV_BOOT_DRIVE, + (PVOID)si, sizeof(si)))) + croak_with_os2error("DosQuerySysInfo() failed"); + c = 'a' - 1 + si[0]; + sv_setpvn(TARG, &c, 1); + XSprePUSH; PUSHTARG; } XSRETURN(1); } @@ -3275,14 +3275,14 @@ XS(XS_OS2_Beep) { dXSARGS; if (items > 2) /* Defaults as for WinAlarm(ERROR) */ - Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)"); + Perl_croak_nocontext("Usage: OS2::Beep(freq = 440, ms = 100)"); { - ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440); - ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100); - ULONG rc; + ULONG freq = (items > 0 ? (ULONG)SvUV(ST(0)) : 440); + ULONG ms = (items > 1 ? (ULONG)SvUV(ST(1)) : 100); + ULONG rc; - if (CheckOSError(DosBeep(freq, ms))) - croak_with_os2error("SysValues_set()"); + if (CheckOSError(DosBeep(freq, ms))) + croak_with_os2error("SysValues_set()"); } XSRETURN_YES; } @@ -3293,13 +3293,13 @@ XS(XS_OS2_MorphPM) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: OS2::MorphPM(serve)"); + Perl_croak_nocontext("Usage: OS2::MorphPM(serve)"); { - bool serve = SvOK(ST(0)); - unsigned long pmq = perl_hmq_GET(serve); - dXSTARG; + bool serve = SvOK(ST(0)); + unsigned long pmq = perl_hmq_GET(serve); + dXSTARG; - XSprePUSH; PUSHi((IV)pmq); + XSprePUSH; PUSHi((IV)pmq); } XSRETURN(1); } @@ -3308,11 +3308,11 @@ XS(XS_OS2_UnMorphPM) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)"); + Perl_croak_nocontext("Usage: OS2::UnMorphPM(serve)"); { - bool serve = SvOK(ST(0)); + bool serve = SvOK(ST(0)); - perl_hmq_UNSET(serve); + perl_hmq_UNSET(serve); } XSRETURN(0); } @@ -3321,13 +3321,13 @@ XS(XS_OS2_Serve_Messages) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)"); + Perl_croak_nocontext("Usage: OS2::Serve_Messages(force)"); { - bool force = SvOK(ST(0)); - unsigned long cnt = Perl_Serve_Messages(force); - dXSTARG; + bool force = SvOK(ST(0)); + unsigned long cnt = Perl_Serve_Messages(force); + dXSTARG; - XSprePUSH; PUSHi((IV)cnt); + XSprePUSH; PUSHi((IV)cnt); } XSRETURN(1); } @@ -3336,26 +3336,26 @@ XS(XS_OS2_Process_Messages) { dXSARGS; if (items < 1 || items > 2) - Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])"); + Perl_croak_nocontext("Usage: OS2::Process_Messages(force [, cnt])"); { - bool force = SvOK(ST(0)); - unsigned long cnt; - dXSTARG; - - if (items == 2) { - I32 cntr; - SV *sv = ST(1); - - (void)SvIV(sv); /* Force SvIVX */ - if (!SvIOK(sv)) - Perl_croak_nocontext("Can't upgrade count to IV"); - cntr = SvIVX(sv); - cnt = Perl_Process_Messages(force, &cntr); - SvIVX(sv) = cntr; - } else { - cnt = Perl_Process_Messages(force, NULL); + bool force = SvOK(ST(0)); + unsigned long cnt; + dXSTARG; + + if (items == 2) { + I32 cntr; + SV *sv = ST(1); + + (void)SvIV(sv); /* Force SvIVX */ + if (!SvIOK(sv)) + Perl_croak_nocontext("Can't upgrade count to IV"); + cntr = SvIVX(sv); + cnt = Perl_Process_Messages(force, &cntr); + SvIVX(sv) = cntr; + } else { + cnt = Perl_Process_Messages(force, NULL); } - XSprePUSH; PUSHi((IV)cnt); + XSprePUSH; PUSHi((IV)cnt); } XSRETURN(1); } @@ -3364,14 +3364,14 @@ XS(XS_Cwd_current_drive) { dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: Cwd::current_drive()"); + Perl_croak_nocontext("Usage: Cwd::current_drive()"); { - char RETVAL; - dXSTARG; + char RETVAL; + dXSTARG; - RETVAL = current_drive(); - sv_setpvn(TARG, (char *)&RETVAL, 1); - XSprePUSH; PUSHTARG; + RETVAL = current_drive(); + sv_setpvn(TARG, (char *)&RETVAL, 1); + XSprePUSH; PUSHTARG; } XSRETURN(1); } @@ -3380,15 +3380,15 @@ XS(XS_Cwd_sys_chdir) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_chdir(path)"); { - STRLEN n_a; - char * path = (char *)SvPV(ST(0),n_a); - bool RETVAL; + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); + bool RETVAL; - RETVAL = sys_chdir(path); - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + RETVAL = sys_chdir(path); + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3397,15 +3397,15 @@ XS(XS_Cwd_change_drive) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: Cwd::change_drive(d)"); + Perl_croak_nocontext("Usage: Cwd::change_drive(d)"); { - STRLEN n_a; - char d = (char)*SvPV(ST(0),n_a); - bool RETVAL; + STRLEN n_a; + char d = (char)*SvPV(ST(0),n_a); + bool RETVAL; - RETVAL = change_drive(d); - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + RETVAL = change_drive(d); + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3414,15 +3414,15 @@ XS(XS_Cwd_sys_is_absolute) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_absolute(path)"); { - STRLEN n_a; - char * path = (char *)SvPV(ST(0),n_a); - bool RETVAL; + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); + bool RETVAL; - RETVAL = sys_is_absolute(path); - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + RETVAL = sys_is_absolute(path); + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3431,15 +3431,15 @@ XS(XS_Cwd_sys_is_rooted) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_rooted(path)"); { - STRLEN n_a; - char * path = (char *)SvPV(ST(0),n_a); - bool RETVAL; + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); + bool RETVAL; - RETVAL = sys_is_rooted(path); - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + RETVAL = sys_is_rooted(path); + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3448,15 +3448,15 @@ XS(XS_Cwd_sys_is_relative) { dXSARGS; if (items != 1) - Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)"); + Perl_croak_nocontext("Usage: Cwd::sys_is_relative(path)"); { - STRLEN n_a; - char * path = (char *)SvPV(ST(0),n_a); - bool RETVAL; + STRLEN n_a; + char * path = (char *)SvPV(ST(0),n_a); + bool RETVAL; - RETVAL = sys_is_relative(path); - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + RETVAL = sys_is_relative(path); + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3465,16 +3465,16 @@ XS(XS_Cwd_sys_cwd) { dXSARGS; if (items != 0) - Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); + Perl_croak_nocontext("Usage: Cwd::sys_cwd()"); { - char p[MAXPATHLEN]; - char * RETVAL; - - /* Can't use TARG, since tainting behaves differently */ - RETVAL = _getcwd2(p, MAXPATHLEN); - ST(0) = sv_newmortal(); - sv_setpv(ST(0), RETVAL); - SvTAINTED_on(ST(0)); + char p[MAXPATHLEN]; + char * RETVAL; + + /* Can't use TARG, since tainting behaves differently */ + RETVAL = _getcwd2(p, MAXPATHLEN); + ST(0) = sv_newmortal(); + sv_setpv(ST(0), RETVAL); + SvTAINTED_on(ST(0)); } XSRETURN(1); } @@ -3483,131 +3483,131 @@ XS(XS_Cwd_sys_abspath) { dXSARGS; if (items > 2) - Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)"); + Perl_croak_nocontext("Usage: Cwd::sys_abspath(path = '.', dir = NULL)"); { - STRLEN n_a; - char * path = items ? (char *)SvPV(ST(0),n_a) : "."; - char * dir, *s, *t, *e; - char p[MAXPATHLEN]; - char * RETVAL; - int l; - SV *sv; - - if (items < 2) - dir = NULL; - else { - dir = (char *)SvPV(ST(1),n_a); - } - if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { - path += 2; - } - if (dir == NULL) { - if (_abspath(p, path, MAXPATHLEN) == 0) { - RETVAL = p; - } else { - RETVAL = NULL; - } - } else { - /* Absolute with drive: */ - if ( sys_is_absolute(path) ) { - if (_abspath(p, path, MAXPATHLEN) == 0) { - RETVAL = p; - } else { - RETVAL = NULL; - } - } else if (path[0] == '/' || path[0] == '\\') { - /* Rooted, but maybe on different drive. */ - if (isALPHA(dir[0]) && dir[1] == ':' ) { - char p1[MAXPATHLEN]; - - /* Need to prepend the drive. */ - p1[0] = dir[0]; - p1[1] = dir[1]; - Copy(path, p1 + 2, strlen(path) + 1, char); - RETVAL = p; - if (_abspath(p, p1, MAXPATHLEN) == 0) { - RETVAL = p; - } else { - RETVAL = NULL; - } - } else if (_abspath(p, path, MAXPATHLEN) == 0) { - RETVAL = p; - } else { - RETVAL = NULL; - } - } else { - /* Either path is relative, or starts with a drive letter. */ - /* If the path starts with a drive letter, then dir is - relevant only if - a/b) it is absolute/x:relative on the same drive. - c) path is on current drive, and dir is rooted - In all the cases it is safe to drop the drive part - of the path. */ - if ( !sys_is_relative(path) ) { - if ( ( ( sys_is_absolute(dir) - || (isALPHA(dir[0]) && dir[1] == ':' - && strnicmp(dir, path,1) == 0)) - && strnicmp(dir, path,1) == 0) - || ( !(isALPHA(dir[0]) && dir[1] == ':') - && toupper(path[0]) == current_drive())) { - path += 2; - } else if (_abspath(p, path, MAXPATHLEN) == 0) { - RETVAL = p; goto done; - } else { - RETVAL = NULL; goto done; - } - } - { - /* Need to prepend the absolute path of dir. */ - char p1[MAXPATHLEN]; - - if (_abspath(p1, dir, MAXPATHLEN) == 0) { - int l = strlen(p1); - - if (p1[ l - 1 ] != '/') { - p1[ l ] = '/'; - l++; - } - Copy(path, p1 + l, strlen(path) + 1, char); - if (_abspath(p, p1, MAXPATHLEN) == 0) { - RETVAL = p; - } else { - RETVAL = NULL; - } - } else { - RETVAL = NULL; - } - } - done: - } - } - if (!RETVAL) - XSRETURN_EMPTY; - /* Backslashes are already converted to slashes. */ - /* Remove trailing slashes */ - l = strlen(RETVAL); - while (l > 0 && RETVAL[l-1] == '/') - l--; - ST(0) = sv_newmortal(); - sv_setpvn( sv = (SV*)ST(0), RETVAL, l); - /* Remove duplicate slashes, skipping the first three, which - may be parts of a server-based path */ - s = t = 3 + SvPV_force(sv, n_a); - e = SvEND(sv); - /* Do not worry about multibyte chars here, this would contradict the - eventual UTFization, and currently most other places break too... */ - while (s < e) { - if (s[0] == t[-1] && s[0] == '/') - s++; /* Skip duplicate / */ - else - *t++ = *s++; - } - if (t < e) { - *t = 0; - SvCUR_set(sv, t - SvPVX(sv)); - } - if (!items) - SvTAINTED_on(ST(0)); + STRLEN n_a; + char * path = items ? (char *)SvPV(ST(0),n_a) : "."; + char * dir, *s, *t, *e; + char p[MAXPATHLEN]; + char * RETVAL; + int l; + SV *sv; + + if (items < 2) + dir = NULL; + else { + dir = (char *)SvPV(ST(1),n_a); + } + if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) { + path += 2; + } + if (dir == NULL) { + if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else { + /* Absolute with drive: */ + if ( sys_is_absolute(path) ) { + if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else if (path[0] == '/' || path[0] == '\\') { + /* Rooted, but maybe on different drive. */ + if (isALPHA(dir[0]) && dir[1] == ':' ) { + char p1[MAXPATHLEN]; + + /* Need to prepend the drive. */ + p1[0] = dir[0]; + p1[1] = dir[1]; + Copy(path, p1 + 2, strlen(path) + 1, char); + RETVAL = p; + if (_abspath(p, p1, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else { + /* Either path is relative, or starts with a drive letter. */ + /* If the path starts with a drive letter, then dir is + relevant only if + a/b) it is absolute/x:relative on the same drive. + c) path is on current drive, and dir is rooted + In all the cases it is safe to drop the drive part + of the path. */ + if ( !sys_is_relative(path) ) { + if ( ( ( sys_is_absolute(dir) + || (isALPHA(dir[0]) && dir[1] == ':' + && strnicmp(dir, path,1) == 0)) + && strnicmp(dir, path,1) == 0) + || ( !(isALPHA(dir[0]) && dir[1] == ':') + && toupper(path[0]) == current_drive())) { + path += 2; + } else if (_abspath(p, path, MAXPATHLEN) == 0) { + RETVAL = p; goto done; + } else { + RETVAL = NULL; goto done; + } + } + { + /* Need to prepend the absolute path of dir. */ + char p1[MAXPATHLEN]; + + if (_abspath(p1, dir, MAXPATHLEN) == 0) { + int l = strlen(p1); + + if (p1[ l - 1 ] != '/') { + p1[ l ] = '/'; + l++; + } + Copy(path, p1 + l, strlen(path) + 1, char); + if (_abspath(p, p1, MAXPATHLEN) == 0) { + RETVAL = p; + } else { + RETVAL = NULL; + } + } else { + RETVAL = NULL; + } + } + done: + } + } + if (!RETVAL) + XSRETURN_EMPTY; + /* Backslashes are already converted to slashes. */ + /* Remove trailing slashes */ + l = strlen(RETVAL); + while (l > 0 && RETVAL[l-1] == '/') + l--; + ST(0) = sv_newmortal(); + sv_setpvn( sv = (SV*)ST(0), RETVAL, l); + /* Remove duplicate slashes, skipping the first three, which + may be parts of a server-based path */ + s = t = 3 + SvPV_force(sv, n_a); + e = SvEND(sv); + /* Do not worry about multibyte chars here, this would contradict the + eventual UTFization, and currently most other places break too... */ + while (s < e) { + if (s[0] == t[-1] && s[0] == '/') + s++; /* Skip duplicate / */ + else + *t++ = *s++; + } + if (t < e) { + *t = 0; + SvCUR_set(sv, t - SvPVX(sv)); + } + if (!items) + SvTAINTED_on(ST(0)); } XSRETURN(1); } @@ -3625,13 +3625,13 @@ ExtLIBPATH(ULONG ord, PSZ path, IV type, int fatal) PFN f = loadByOrdinal(ord, fatal); /* if fatal: load or die! */ if (!f) /* Impossible with fatal */ - return Perl_rc; + return Perl_rc; if (type > 0) - what = END_LIBPATH; + what = END_LIBPATH; else if (type == 0) - what = BEGIN_LIBPATH; + what = BEGIN_LIBPATH; else - what = LIBPATHSTRICT; + what = LIBPATHSTRICT; return (*(PELP)f)(path, what); } @@ -3656,31 +3656,31 @@ XS(XS_Cwd_extLibpath) { dXSARGS; if (items < 0 || items > 1) - Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)"); + Perl_croak_nocontext("Usage: OS2::extLibpath(type = 0)"); { - IV type; - char to[1024]; - U32 rc; - char * RETVAL; - dXSTARG; - STRLEN l; - - if (items < 1) - type = 0; - else { - type = SvIV(ST(0)); - } - - to[0] = 1; to[1] = 0; /* Sometimes no error reported */ - RETVAL = extLibpath(to, type, 1); /* Make errors fatal */ - if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0) - Perl_croak_nocontext("panic OS2::extLibpath parameter"); - l = strlen(to); - if (l >= sizeof(to)) - early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `", - to, "'\r\n"); /* Will not return */ - sv_setpv(TARG, RETVAL); - XSprePUSH; PUSHTARG; + IV type; + char to[1024]; + U32 rc; + char * RETVAL; + dXSTARG; + STRLEN l; + + if (items < 1) + type = 0; + else { + type = SvIV(ST(0)); + } + + to[0] = 1; to[1] = 0; /* Sometimes no error reported */ + RETVAL = extLibpath(to, type, 1); /* Make errors fatal */ + if (RETVAL && RETVAL[0] == 1 && RETVAL[1] == 0) + Perl_croak_nocontext("panic OS2::extLibpath parameter"); + l = strlen(to); + if (l >= sizeof(to)) + early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `", + to, "'\r\n"); /* Will not return */ + sv_setpv(TARG, RETVAL); + XSprePUSH; PUSHTARG; } XSRETURN(1); } @@ -3689,23 +3689,23 @@ XS(XS_Cwd_extLibpath_set) { dXSARGS; if (items < 1 || items > 2) - Perl_croak_nocontext("Usage: OS2::extLibpath_set(s, type = 0)"); + Perl_croak_nocontext("Usage: OS2::extLibpath_set(s, type = 0)"); { - STRLEN n_a; - char * s = (char *)SvPV(ST(0),n_a); - IV type; - U32 rc; - bool RETVAL; - - if (items < 2) - type = 0; - else { - type = SvIV(ST(1)); - } - - RETVAL = extLibpath_set(s, type, 1); /* Make errors fatal */ - ST(0) = boolSV(RETVAL); - if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); + STRLEN n_a; + char * s = (char *)SvPV(ST(0),n_a); + IV type; + U32 rc; + bool RETVAL; + + if (items < 2) + type = 0; + else { + type = SvIV(ST(1)); + } + + RETVAL = extLibpath_set(s, type, 1); /* Make errors fatal */ + ST(0) = boolSV(RETVAL); + if (SvREFCNT(ST(0))) sv_2mortal(ST(0)); } XSRETURN(1); } @@ -3718,53 +3718,53 @@ fill_extLibpath(int type, char *pre, char *post, int replace, char *msg) ULONG rc; if (!pre && !post) - return 0; + return 0; if (pre) { - pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg); - if (!pre) - return ERROR_INVALID_PARAMETER; - l = strlen(pre); - if (l >= sizeof(buf)/2) - return ERROR_BUFFER_OVERFLOW; - s = pre - 1; - while (*++s) - if (*s == '/') - *s = '\\'; /* Be extra cautious */ - memcpy(to, pre, l); - if (!l || to[l-1] != ';') - to[l++] = ';'; - to += l; + pre = dir_subst(pre, strlen(pre), buf1, sizeof buf1, dir_subst_pathlike, msg); + if (!pre) + return ERROR_INVALID_PARAMETER; + l = strlen(pre); + if (l >= sizeof(buf)/2) + return ERROR_BUFFER_OVERFLOW; + s = pre - 1; + while (*++s) + if (*s == '/') + *s = '\\'; /* Be extra cautious */ + memcpy(to, pre, l); + if (!l || to[l-1] != ';') + to[l++] = ';'; + to += l; } if (!replace) { to[0] = 1; to[1] = 0; /* Sometimes no error reported */ rc = ExtLIBPATH(ORD_DosQueryExtLibpath, to, type, 0); /* Do not croak */ if (rc) - return rc; + return rc; if (to[0] == 1 && to[1] == 0) - return ERROR_INVALID_PARAMETER; + return ERROR_INVALID_PARAMETER; to += strlen(to); if (buf + sizeof(buf) - 1 <= to) /* Buffer overflow */ - early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `", - buf, "'\r\n"); /* Will not return */ + early_error("Buffer overflow while getting BEGIN/ENDLIBPATH: `", + buf, "'\r\n"); /* Will not return */ if (to > buf && to[-1] != ';') - *to++ = ';'; + *to++ = ';'; } if (post) { - post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg); - if (!post) - return ERROR_INVALID_PARAMETER; - l = strlen(post); - if (l + to - buf >= sizeof(buf) - 1) - return ERROR_BUFFER_OVERFLOW; - s = post - 1; - while (*++s) - if (*s == '/') - *s = '\\'; /* Be extra cautious */ - memcpy(to, post, l); - if (!l || to[l-1] != ';') - to[l++] = ';'; - to += l; + post = dir_subst(post, strlen(post), buf1, sizeof buf1, dir_subst_pathlike, msg); + if (!post) + return ERROR_INVALID_PARAMETER; + l = strlen(post); + if (l + to - buf >= sizeof(buf) - 1) + return ERROR_BUFFER_OVERFLOW; + s = post - 1; + while (*++s) + if (*s == '/') + *s = '\\'; /* Be extra cautious */ + memcpy(to, post, l); + if (!l || to[l-1] != ';') + to[l++] = ';'; + to += l; } *to = 0; rc = ExtLIBPATH(ORD_DosSetExtLibpath, buf, type, 0); /* Do not croak */ @@ -3774,13 +3774,13 @@ fill_extLibpath(int type, char *pre, char *post, int replace, char *msg) /* Input: Address, BufLen APIRET APIENTRY DosQueryModFromEIP (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, - ULONG * Offset, ULONG Address); + ULONG * Offset, ULONG Address); */ DeclOSFuncByORD(APIRET, _DosQueryModFromEIP,ORD_DosQueryModFromEIP, - (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, - ULONG * Offset, ULONG Address), - (hmod, obj, BufLen, Buf, Offset, Address)) + (HMODULE * hmod, ULONG * obj, ULONG BufLen, PCHAR Buf, + ULONG * Offset, ULONG Address), + (hmod, obj, BufLen, Buf, Offset, Address)) static SV* module_name_at(void *pp, enum module_name_how how) @@ -3792,22 +3792,22 @@ module_name_at(void *pp, enum module_name_how how) ULONG obj, offset, rc, addr = (ULONG)pp; if (how & mod_name_HMODULE) { - if ((how & ~mod_name_HMODULE) == mod_name_shortname) - Perl_croak(aTHX_ "Can't get short module name from a handle"); - mod = (HMODULE)pp; - how &= ~mod_name_HMODULE; + if ((how & ~mod_name_HMODULE) == mod_name_shortname) + Perl_croak(aTHX_ "Can't get short module name from a handle"); + mod = (HMODULE)pp; + how &= ~mod_name_HMODULE; } else if (!_DosQueryModFromEIP(&mod, &obj, sizeof(buf), buf, &offset, addr)) - return &PL_sv_undef; + return &PL_sv_undef; if (how == mod_name_handle) - return newSVuv(mod); + return newSVuv(mod); /* Full name... */ if ( how != mod_name_shortname - && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) ) - return &PL_sv_undef; + && CheckOSError(DosQueryModuleName(mod, sizeof(buf), buf)) ) + return &PL_sv_undef; while (*p) { - if (*p == '\\') - *p = '/'; - p++; + if (*p == '\\') + *p = '/'; + p++; } return newSVpv(buf, 0); } @@ -3816,13 +3816,13 @@ static SV* module_name_of_cv(SV *cv, enum module_name_how how) { if (!cv || !SvROK(cv) || SvTYPE(SvRV(cv)) != SVt_PVCV || !CvXSUB(SvRV(cv))) { - dTHX; + dTHX; - if (how & mod_name_C_function) - return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function); - else if (how & mod_name_HMODULE) - return module_name_at((void*)SvIV(cv), how); - Perl_croak(aTHX_ "Not an XSUB reference"); + if (how & mod_name_C_function) + return module_name_at((void*)SvIV(cv), how & ~mod_name_C_function); + else if (how & mod_name_HMODULE) + return module_name_at((void*)SvIV(cv), how); + Perl_croak(aTHX_ "Not an XSUB reference"); } return module_name_at(CvXSUB(SvRV(cv)), how); } @@ -3831,52 +3831,52 @@ XS(XS_OS2_DLLname) { dXSARGS; if (items > 2) - Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )"); + Perl_croak(aTHX_ "Usage: OS2::DLLname( [ how, [\\&xsub] ] )"); { - SV * RETVAL; - int how; - - if (items < 1) - how = mod_name_full; - else { - how = (int)SvIV(ST(0)); - } - if (items < 2) - RETVAL = module_name(how); - else - RETVAL = module_name_of_cv(ST(1), how); - ST(0) = RETVAL; - sv_2mortal(ST(0)); + SV * RETVAL; + int how; + + if (items < 1) + how = mod_name_full; + else { + how = (int)SvIV(ST(0)); + } + if (items < 2) + RETVAL = module_name(how); + else + RETVAL = module_name_of_cv(ST(1), how); + ST(0) = RETVAL; + sv_2mortal(ST(0)); } XSRETURN(1); } DeclOSFuncByORD(INT, _Dos32QueryHeaderInfo, ORD_Dos32QueryHeaderInfo, - (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum), - (r1, r2, buf, szbuf, fnum)) + (ULONG r1, ULONG r2, PVOID buf, ULONG szbuf, ULONG fnum), + (r1, r2, buf, szbuf, fnum)) XS(XS_OS2__headerInfo) { dXSARGS; if (items > 4 || items < 2) - Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])"); + Perl_croak(aTHX_ "Usage: OS2::_headerInfo(req,size[,handle,[offset]])"); { - ULONG req = (ULONG)SvIV(ST(0)); - STRLEN size = (STRLEN)SvIV(ST(1)), n_a; - ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0); - ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0); - - if (size <= 0) - Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size); - ST(0) = newSVpvs(""); - SvGROW(ST(0), size + 1); - sv_2mortal(ST(0)); - - if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req)) - Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", - req, size, handle, offset, os2error(Perl_rc)); - SvCUR_set(ST(0), size); - *SvEND(ST(0)) = 0; + ULONG req = (ULONG)SvIV(ST(0)); + STRLEN size = (STRLEN)SvIV(ST(1)), n_a; + ULONG handle = (items >= 3 ? (ULONG)SvIV(ST(2)) : 0); + ULONG offset = (items >= 4 ? (ULONG)SvIV(ST(3)) : 0); + + if (size <= 0) + Perl_croak(aTHX_ "OS2::_headerInfo(): unexpected size: %d", (int)size); + ST(0) = newSVpvs(""); + SvGROW(ST(0), size + 1); + sv_2mortal(ST(0)); + + if (!_Dos32QueryHeaderInfo(handle, offset, SvPV(ST(0), n_a), size, req)) + Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", + req, size, handle, offset, os2error(Perl_rc)); + SvCUR_set(ST(0), size); + *SvEND(ST(0)) = 0; } XSRETURN(1); } @@ -3888,29 +3888,29 @@ XS(XS_OS2_libPath) { dXSARGS; if (items != 0) - Perl_croak(aTHX_ "Usage: OS2::libPath()"); + Perl_croak(aTHX_ "Usage: OS2::libPath()"); { - ULONG size; - STRLEN n_a; - - if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size), - DQHI_QUERYLIBPATHSIZE)) - Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", - DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0, - os2error(Perl_rc)); - ST(0) = newSVpvs(""); - SvGROW(ST(0), size + 1); - sv_2mortal(ST(0)); - - /* We should be careful: apparently, this entry point does not - pay attention to the size argument, so may overwrite - unrelated data! */ - if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size, - DQHI_QUERYLIBPATH)) - Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", - DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc)); - SvCUR_set(ST(0), size); - *SvEND(ST(0)) = 0; + ULONG size; + STRLEN n_a; + + if (!_Dos32QueryHeaderInfo(0, 0, &size, sizeof(size), + DQHI_QUERYLIBPATHSIZE)) + Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", + DQHI_QUERYLIBPATHSIZE, sizeof(size), 0, 0, + os2error(Perl_rc)); + ST(0) = newSVpvs(""); + SvGROW(ST(0), size + 1); + sv_2mortal(ST(0)); + + /* We should be careful: apparently, this entry point does not + pay attention to the size argument, so may overwrite + unrelated data! */ + if (!_Dos32QueryHeaderInfo(0, 0, SvPV(ST(0), n_a), size, + DQHI_QUERYLIBPATH)) + Perl_croak(aTHX_ "OS2::_headerInfo(%ld,%ld,%ld,%ld) error: %s", + DQHI_QUERYLIBPATH, size, 0, 0, os2error(Perl_rc)); + SvCUR_set(ST(0), size); + *SvEND(ST(0)) = 0; } XSRETURN(1); } @@ -3922,15 +3922,15 @@ XS(XS_OS2__control87) { dXSARGS; if (items != 2) - Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)"); + Perl_croak(aTHX_ "Usage: OS2::_control87(new,mask)"); { - unsigned new = (unsigned)SvIV(ST(0)); - unsigned mask = (unsigned)SvIV(ST(1)); - unsigned RETVAL; - dXSTARG; + unsigned new = (unsigned)SvIV(ST(0)); + unsigned mask = (unsigned)SvIV(ST(1)); + unsigned RETVAL; + dXSTARG; - RETVAL = _control87(new, mask); - XSprePUSH; PUSHi((IV)RETVAL); + RETVAL = _control87(new, mask); + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -3941,30 +3941,30 @@ XS(XS_OS2_mytype) int which = 0; if (items < 0 || items > 1) - Perl_croak(aTHX_ "Usage: OS2::mytype([which])"); + Perl_croak(aTHX_ "Usage: OS2::mytype([which])"); if (items == 1) - which = (int)SvIV(ST(0)); + which = (int)SvIV(ST(0)); { - unsigned RETVAL; - dXSTARG; - - switch (which) { - case 0: - RETVAL = os2_mytype; /* Reset after fork */ - break; - case 1: - RETVAL = os2_mytype_ini; /* Before any fork */ - break; - case 2: - RETVAL = Perl_os2_initial_mode; /* Before first morphing */ - break; - case 3: - RETVAL = my_type(); /* Morphed type */ - break; - default: - Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which); - } - XSprePUSH; PUSHi((IV)RETVAL); + unsigned RETVAL; + dXSTARG; + + switch (which) { + case 0: + RETVAL = os2_mytype; /* Reset after fork */ + break; + case 1: + RETVAL = os2_mytype_ini; /* Before any fork */ + break; + case 2: + RETVAL = Perl_os2_initial_mode; /* Before first morphing */ + break; + case 3: + RETVAL = my_type(); /* Morphed type */ + break; + default: + Perl_croak(aTHX_ "OS2::mytype(which): unknown which=%d", which); + } + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -3976,9 +3976,9 @@ XS(XS_OS2_mytype_set) int type; if (items == 1) - type = (int)SvIV(ST(0)); + type = (int)SvIV(ST(0)); else - Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)"); + Perl_croak(aTHX_ "Usage: OS2::mytype_set(type)"); my_type_set(type); XSRETURN_YES; } @@ -3988,13 +3988,13 @@ XS(XS_OS2_get_control87) { dXSARGS; if (items != 0) - Perl_croak(aTHX_ "Usage: OS2::get_control87()"); + Perl_croak(aTHX_ "Usage: OS2::get_control87()"); { - unsigned RETVAL; - dXSTARG; + unsigned RETVAL; + dXSTARG; - RETVAL = get_control87(); - XSprePUSH; PUSHi((IV)RETVAL); + RETVAL = get_control87(); + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -4004,27 +4004,27 @@ XS(XS_OS2_set_control87) { dXSARGS; if (items < 0 || items > 2) - Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)"); + Perl_croak(aTHX_ "Usage: OS2::set_control87(new=MCW_EM, mask=MCW_EM)"); { - unsigned new; - unsigned mask; - unsigned RETVAL; - dXSTARG; - - if (items < 1) - new = MCW_EM; - else { - new = (unsigned)SvIV(ST(0)); - } - - if (items < 2) - mask = MCW_EM; - else { - mask = (unsigned)SvIV(ST(1)); - } - - RETVAL = set_control87(new, mask); - XSprePUSH; PUSHi((IV)RETVAL); + unsigned new; + unsigned mask; + unsigned RETVAL; + dXSTARG; + + if (items < 1) + new = MCW_EM; + else { + new = (unsigned)SvIV(ST(0)); + } + + if (items < 2) + mask = MCW_EM; + else { + mask = (unsigned)SvIV(ST(1)); + } + + RETVAL = set_control87(new, mask); + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -4033,20 +4033,20 @@ XS(XS_OS2_incrMaxFHandles) /* DosSetRelMaxFH */ { dXSARGS; if (items < 0 || items > 1) - Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)"); + Perl_croak(aTHX_ "Usage: OS2::incrMaxFHandles(delta = 0)"); { - LONG delta; - ULONG RETVAL, rc; - dXSTARG; - - if (items < 1) - delta = 0; - else - delta = (LONG)SvIV(ST(0)); - - if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL))) - croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error"); - XSprePUSH; PUSHu((UV)RETVAL); + LONG delta; + ULONG RETVAL, rc; + dXSTARG; + + if (items < 1) + delta = 0; + else + delta = (LONG)SvIV(ST(0)); + + if (CheckOSError(DosSetRelMaxFH(&delta, &RETVAL))) + croak_with_os2error("OS2::incrMaxFHandles(): DosSetRelMaxFH() error"); + XSprePUSH; PUSHu((UV)RETVAL); } XSRETURN(1); } @@ -4061,24 +4061,24 @@ connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags) ULONG ret = ERROR_INTERRUPT, rc, flags; if (restore && wait) - os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()"); + os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()"); /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */ oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE); flags = (oflags & ~NP_NOWAIT) | (wait > 0 ? NP_WAIT : NP_NOWAIT); /* We know (o)flags unless wait == 0 && restore */ if (wait && (flags != oflags)) - os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()"); + os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()"); while (ret == ERROR_INTERRUPT) - ret = DosConnectNPipe(hpipe); + ret = DosConnectNPipe(hpipe); (void)CheckOSError(ret); if (restore && wait && (flags != oflags)) - os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back"); + os2cp_croak(DosSetNPHState(hpipe, oflags), "DosSetNPHState() back"); /* We know flags unless wait == 0 && restore */ if ( ((wait || restore) ? (flags & NP_NOWAIT) : 1) - && (ret == ERROR_PIPE_NOT_CONNECTED) ) - return 0; /* normal return value */ + && (ret == ERROR_PIPE_NOT_CONNECTED) ) + return 0; /* normal return value */ if (ret == NO_ERROR) - return 1; + return 1; croak_with_os2error("DosConnectNPipe()"); } @@ -4086,196 +4086,196 @@ connectNPipe(ULONG hpipe, int wait, ULONG restore, ULONG oflags) NO_OUTPUT ULONG DosCreateNPipe(PCSZ pszName, OUTLIST HPIPE hpipe, ULONG ulOpenMode, int connect = 1, int count = 1, ULONG ulInbufLength = 8192, ULONG ulOutbufLength = ulInbufLength, ULONG ulPipeMode = count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ULONG ulTimeout = 0) PREINIT: - ULONG rc; + ULONG rc; C_ARGS: - pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout + pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout POSTCALL: - if (CheckOSError(RETVAL)) - croak_with_os2error("OS2::mkpipe() error"); + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::mkpipe() error"); */ XS(XS_OS2_pipe); /* prototype to pass -Wmissing-prototypes */ XS(XS_OS2_pipe) { dXSARGS; if (items < 2 || items > 8) - Perl_croak(aTHX_ "Usage: OS2::pipe(pszName, ulOpenMode, connect= 1, count= 1, ulInbufLength= 8192, ulOutbufLength= ulInbufLength, ulPipeMode= count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ulTimeout= 0)"); + Perl_croak(aTHX_ "Usage: OS2::pipe(pszName, ulOpenMode, connect= 1, count= 1, ulInbufLength= 8192, ulOutbufLength= ulInbufLength, ulPipeMode= count | NP_NOWAIT | NP_TYPE_BYTE | NP_READMODE_BYTE, ulTimeout= 0)"); { - ULONG RETVAL; - PCSZ pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL ); - HPIPE hpipe; - SV *OpenMode = ST(1); - ULONG ulOpenMode; - int connect = 0, count, message_r = 0, message = 0, b = 0; - ULONG ulInbufLength, ulOutbufLength, ulPipeMode, ulTimeout, rc; - STRLEN len; - char *s, buf[10], *s1, *perltype = NULL; - PerlIO *perlio; - double timeout; - - if (!pszName || !*pszName) - Perl_croak(aTHX_ "OS2::pipe(): empty pipe name"); - s = SvPV(OpenMode, len); - if (memEQs(s, len, "wait")) { /* DosWaitNPipe() */ - ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */ - - if (items == 3) { - timeout = (double)SvNV(ST(2)); - ms = timeout * 1000; - if (timeout < 0) - ms = 0xFFFFFFFF; /* Indefinite */ - else if (timeout && !ms) - ms = 1; - } else if (items > 3) - Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items); - - while (ret == ERROR_INTERRUPT) - ret = DosWaitNPipe(pszName, ms); /* XXXX Update ms? */ - os2cp_croak(ret, "DosWaitNPipe()"); - XSRETURN_YES; - } - if (memEQs(s, len, "call")) { /* DosCallNPipe() */ - ULONG ms = 0xFFFFFFFF, got; /* Indefinite */ - STRLEN l; - char *s; - char buf[8192]; - STRLEN ll = sizeof(buf); - char *b = buf; - - if (items < 3 || items > 5) - Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])"); - s = SvPV(ST(2), l); - if (items >= 4) { - timeout = (double)SvNV(ST(3)); - ms = timeout * 1000; - if (timeout < 0) - ms = 0xFFFFFFFF; /* Indefinite */ - else if (timeout && !ms) - ms = 1; - } - if (items >= 5) { - STRLEN lll = SvUV(ST(4)); - SV *sv = NEWSV(914, lll); - - sv_2mortal(sv); - ll = lll; - b = SvPVX(sv); - } - - os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms), - "DosCallNPipe()"); - XSRETURN_PVN(b, got); - } - s1 = buf; - if (len && len <= 3 && !(*s >= '0' && *s <= '9')) { - int r, w, R, W; - - r = strchr(s, 'r') != 0; - w = strchr(s, 'w') != 0; - R = strchr(s, 'R') != 0; - W = strchr(s, 'W') != 0; - b = strchr(s, 'b') != 0; - if (r + w + R + W + b != len || (r && R) || (w && W)) - Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s); - if ((r || R) && (w || W)) - ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX; - else if (r || R) - ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND; - else - ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND; - if (R) - message = message_r = 1; - if (W) - message = 1; - else if (w && R) - Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes"); - } else - ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */ - - if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX - || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND ) - *s1++ = 'r'; - if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX ) - *s1++ = '+'; - if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND ) - *s1++ = 'w'; - if (b) - *s1++ = 'b'; - *s1 = 0; - if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX ) - perltype = "+<&"; - else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND ) - perltype = ">&"; - else - perltype = "<&"; - - if (items < 3) - connect = -1; /* no wait */ - else if (SvTRUE(ST(2))) { - s = SvPV(ST(2), len); - if (memEQs(s, len, "nowait")) - connect = -1; /* no wait */ - else if (memEQs(s, len, "wait")) - connect = 1; /* wait */ - else - Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s); - } - - if (items < 4) - count = 1; - else - count = (int)SvIV(ST(3)); - - if (items < 5) - ulInbufLength = 8192; - else - ulInbufLength = (ULONG)SvUV(ST(4)); - - if (items < 6) - ulOutbufLength = ulInbufLength; - else - ulOutbufLength = (ULONG)SvUV(ST(5)); - - if (count < -1 || count == 0 || count >= 255) - Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count); - if (count < 0 ) - count = 255; /* Unlimited */ - - ulPipeMode = count; - if (items < 7) - ulPipeMode |= (NP_WAIT - | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE) - | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE)); - else - ulPipeMode |= (ULONG)SvUV(ST(6)); - - if (items < 8) - timeout = 0; - else - timeout = (double)SvNV(ST(7)); - ulTimeout = timeout * 1000; - if (timeout < 0) - ulTimeout = 0xFFFFFFFF; /* Indefinite */ - else if (timeout && !ulTimeout) - ulTimeout = 1; - - RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout); - if (CheckOSError(RETVAL)) - croak_with_os2error("OS2::pipe(): DosCreateNPipe() error"); - - if (connect) - connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */ - hpipe = __imphandle(hpipe); - - perlio = PerlIO_fdopen(hpipe, buf); - ST(0) = sv_newmortal(); - { - GV *gv = (GV *)sv_newmortal(); - gv_init_pvn(gv, gv_stashpvs("OS2::pipe",1),"__ANONIO__",10,0); - if ( do_open6(gv, perltype, strlen(perltype), perlio, NULL, 0) ) - sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1))); - else - ST(0) = &PL_sv_undef; - } + ULONG RETVAL; + PCSZ pszName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL ); + HPIPE hpipe; + SV *OpenMode = ST(1); + ULONG ulOpenMode; + int connect = 0, count, message_r = 0, message = 0, b = 0; + ULONG ulInbufLength, ulOutbufLength, ulPipeMode, ulTimeout, rc; + STRLEN len; + char *s, buf[10], *s1, *perltype = NULL; + PerlIO *perlio; + double timeout; + + if (!pszName || !*pszName) + Perl_croak(aTHX_ "OS2::pipe(): empty pipe name"); + s = SvPV(OpenMode, len); + if (memEQs(s, len, "wait")) { /* DosWaitNPipe() */ + ULONG ms = 0xFFFFFFFF, ret = ERROR_INTERRUPT; /* Indefinite */ + + if (items == 3) { + timeout = (double)SvNV(ST(2)); + ms = timeout * 1000; + if (timeout < 0) + ms = 0xFFFFFFFF; /* Indefinite */ + else if (timeout && !ms) + ms = 1; + } else if (items > 3) + Perl_croak(aTHX_ "OS2::pipe(): too many arguments for wait-for-connect: %ld", (long)items); + + while (ret == ERROR_INTERRUPT) + ret = DosWaitNPipe(pszName, ms); /* XXXX Update ms? */ + os2cp_croak(ret, "DosWaitNPipe()"); + XSRETURN_YES; + } + if (memEQs(s, len, "call")) { /* DosCallNPipe() */ + ULONG ms = 0xFFFFFFFF, got; /* Indefinite */ + STRLEN l; + char *s; + char buf[8192]; + STRLEN ll = sizeof(buf); + char *b = buf; + + if (items < 3 || items > 5) + Perl_croak(aTHX_ "usage: OS2::pipe(pszName, 'call', write [, timeout= 0xFFFFFFFF, buffsize = 8192])"); + s = SvPV(ST(2), l); + if (items >= 4) { + timeout = (double)SvNV(ST(3)); + ms = timeout * 1000; + if (timeout < 0) + ms = 0xFFFFFFFF; /* Indefinite */ + else if (timeout && !ms) + ms = 1; + } + if (items >= 5) { + STRLEN lll = SvUV(ST(4)); + SV *sv = NEWSV(914, lll); + + sv_2mortal(sv); + ll = lll; + b = SvPVX(sv); + } + + os2cp_croak(DosCallNPipe(pszName, s, l, b, ll, &got, ms), + "DosCallNPipe()"); + XSRETURN_PVN(b, got); + } + s1 = buf; + if (len && len <= 3 && !(*s >= '0' && *s <= '9')) { + int r, w, R, W; + + r = strchr(s, 'r') != 0; + w = strchr(s, 'w') != 0; + R = strchr(s, 'R') != 0; + W = strchr(s, 'W') != 0; + b = strchr(s, 'b') != 0; + if (r + w + R + W + b != len || (r && R) || (w && W)) + Perl_croak(aTHX_ "OS2::pipe(): unknown OpenMode argument: `%s'", s); + if ((r || R) && (w || W)) + ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_DUPLEX; + else if (r || R) + ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_INBOUND; + else + ulOpenMode = NP_INHERIT | NP_NOWRITEBEHIND | NP_ACCESS_OUTBOUND; + if (R) + message = message_r = 1; + if (W) + message = 1; + else if (w && R) + Perl_croak(aTHX_ "OS2::pipe(): can't have message read mode for non-message pipes"); + } else + ulOpenMode = (ULONG)SvUV(OpenMode); /* ST(1) */ + + if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX + || (ulOpenMode & 0x3) == NP_ACCESS_INBOUND ) + *s1++ = 'r'; + if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX ) + *s1++ = '+'; + if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND ) + *s1++ = 'w'; + if (b) + *s1++ = 'b'; + *s1 = 0; + if ( (ulOpenMode & 0x3) == NP_ACCESS_DUPLEX ) + perltype = "+<&"; + else if ( (ulOpenMode & 0x3) == NP_ACCESS_OUTBOUND ) + perltype = ">&"; + else + perltype = "<&"; + + if (items < 3) + connect = -1; /* no wait */ + else if (SvTRUE(ST(2))) { + s = SvPV(ST(2), len); + if (memEQs(s, len, "nowait")) + connect = -1; /* no wait */ + else if (memEQs(s, len, "wait")) + connect = 1; /* wait */ + else + Perl_croak(aTHX_ "OS2::pipe(): unknown connect argument: `%s'", s); + } + + if (items < 4) + count = 1; + else + count = (int)SvIV(ST(3)); + + if (items < 5) + ulInbufLength = 8192; + else + ulInbufLength = (ULONG)SvUV(ST(4)); + + if (items < 6) + ulOutbufLength = ulInbufLength; + else + ulOutbufLength = (ULONG)SvUV(ST(5)); + + if (count < -1 || count == 0 || count >= 255) + Perl_croak(aTHX_ "OS2::pipe(): count should be -1 or between 1 and 254: %ld", (long)count); + if (count < 0 ) + count = 255; /* Unlimited */ + + ulPipeMode = count; + if (items < 7) + ulPipeMode |= (NP_WAIT + | (message ? NP_TYPE_MESSAGE : NP_TYPE_BYTE) + | (message_r ? NP_READMODE_MESSAGE : NP_READMODE_BYTE)); + else + ulPipeMode |= (ULONG)SvUV(ST(6)); + + if (items < 8) + timeout = 0; + else + timeout = (double)SvNV(ST(7)); + ulTimeout = timeout * 1000; + if (timeout < 0) + ulTimeout = 0xFFFFFFFF; /* Indefinite */ + else if (timeout && !ulTimeout) + ulTimeout = 1; + + RETVAL = DosCreateNPipe(pszName, &hpipe, ulOpenMode, ulPipeMode, ulInbufLength, ulOutbufLength, ulTimeout); + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::pipe(): DosCreateNPipe() error"); + + if (connect) + connectNPipe(hpipe, connect, 1, 0); /* XXXX wait, retval */ + hpipe = __imphandle(hpipe); + + perlio = PerlIO_fdopen(hpipe, buf); + ST(0) = sv_newmortal(); + { + GV *gv = (GV *)sv_newmortal(); + gv_init_pvn(gv, gv_stashpvs("OS2::pipe",1),"__ANONIO__",10,0); + if ( do_open6(gv, perltype, strlen(perltype), perlio, NULL, 0) ) + sv_setsv(ST(0), sv_bless(newRV((SV*)gv), gv_stashpv("IO::Handle",1))); + else + ST(0) = &PL_sv_undef; + } } XSRETURN(1); } @@ -4285,155 +4285,155 @@ XS(XS_OS2_pipeCntl) { dXSARGS; if (items < 2 || items > 3) - Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])"); + Perl_croak(aTHX_ "Usage: OS2::pipeCntl(pipe, op [, wait])"); { - ULONG rc; - PerlIO *perlio = IoIFP(sv_2io(ST(0))); - IV fn = PerlIO_fileno(perlio); - HPIPE hpipe = (HPIPE)fn; - STRLEN len; - char *s = SvPV(ST(1), len); - int wait = 0, disconnect = 0, connect = 0, message = -1, query = 0; - int peek = 0, state = 0, info = 0; - - if (fn < 0) - Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe"); - if (items == 3) - wait = (SvTRUE(ST(2)) ? 1 : -1); - - switch (len) { - case 4: - if (strEQ(s, "byte")) - message = 0; - else if (strEQ(s, "peek")) - peek = 1; - else if (strEQ(s, "info")) - info = 1; - else - goto unknown; - break; - case 5: - if (strEQ(s, "reset")) - disconnect = connect = 1; - else if (strEQ(s, "state")) - query = 1; - else - goto unknown; - break; - case 7: - if (strEQ(s, "connect")) - connect = 1; - else if (strEQ(s, "message")) - message = 1; - else - goto unknown; - break; - case 9: - if (!strEQ(s, "readstate")) - goto unknown; - state = 1; - break; - case 10: - if (!strEQ(s, "disconnect")) - goto unknown; - disconnect = 1; - break; - default: - unknown: - Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s); - break; - } - - if (items == 3 && !connect) - Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s); - - XSprePUSH; /* Do not need arguments any more */ - if (disconnect) { - os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()"); - PerlIO_clearerr(perlio); - } - if (connect) { - if (!connectNPipe(hpipe, wait , 1, 0)) - XSRETURN_IV(-1); - } - if (query) { - ULONG flags; - - os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()"); - XSRETURN_UV(flags); - } - if (peek || state || info) { - ULONG BytesRead, PipeState; - AVAILDATA BytesAvail; - - os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail, - &PipeState), "DosPeekNPipe() for state"); - if (state) { - EXTEND(SP, 3); - mPUSHu(PipeState); - /* Bytes (available/in-message) */ - mPUSHi(BytesAvail.cbpipe); - mPUSHi(BytesAvail.cbmessage); - XSRETURN(3); - } else if (info) { - /* L S S C C C/Z* - ID of the (remote) computer - buffers (out/in) - instances (max/actual) - */ - struct pipe_info_t { - ULONG id; /* char id[4]; */ - PIPEINFO pInfo; - char buf[512]; - } b; - int size; - - os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)), - "DosQueryNPipeInfo(1)"); - os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)), - "DosQueryNPipeInfo(2)"); - size = b.pInfo.cbName; - /* Trailing 0 is included in cbName - undocumented; so - one should always extract with Z* */ - if (size) /* name length 254 or less */ - size--; - else - size = strlen(b.pInfo.szName); - EXTEND(SP, 6); - mPUSHp(b.pInfo.szName, size); - mPUSHu(b.id); - mPUSHi(b.pInfo.cbOut); - mPUSHi(b.pInfo.cbIn); - mPUSHi(b.pInfo.cbMaxInst); - mPUSHi(b.pInfo.cbCurInst); - XSRETURN(6); - } else if (BytesAvail.cbpipe == 0) { - XSRETURN_NO; - } else { - SV *tmp = NEWSV(914, BytesAvail.cbpipe); - char *s = SvPVX(tmp); - - sv_2mortal(tmp); - os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead, - &BytesAvail, &PipeState), "DosPeekNPipe()"); - SvCUR_set(tmp, BytesRead); - *SvEND(tmp) = 0; - SvPOK_on(tmp); - XSprePUSH; PUSHs(tmp); - XSRETURN(1); - } - } - if (message > -1) { - ULONG oflags, flags; - - os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()"); - /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */ - oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE); - flags = (oflags & NP_NOWAIT) - | (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE); - if (flags != oflags) - os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()"); - } + ULONG rc; + PerlIO *perlio = IoIFP(sv_2io(ST(0))); + IV fn = PerlIO_fileno(perlio); + HPIPE hpipe = (HPIPE)fn; + STRLEN len; + char *s = SvPV(ST(1), len); + int wait = 0, disconnect = 0, connect = 0, message = -1, query = 0; + int peek = 0, state = 0, info = 0; + + if (fn < 0) + Perl_croak(aTHX_ "OS2::pipeCntl(): not a pipe"); + if (items == 3) + wait = (SvTRUE(ST(2)) ? 1 : -1); + + switch (len) { + case 4: + if (strEQ(s, "byte")) + message = 0; + else if (strEQ(s, "peek")) + peek = 1; + else if (strEQ(s, "info")) + info = 1; + else + goto unknown; + break; + case 5: + if (strEQ(s, "reset")) + disconnect = connect = 1; + else if (strEQ(s, "state")) + query = 1; + else + goto unknown; + break; + case 7: + if (strEQ(s, "connect")) + connect = 1; + else if (strEQ(s, "message")) + message = 1; + else + goto unknown; + break; + case 9: + if (!strEQ(s, "readstate")) + goto unknown; + state = 1; + break; + case 10: + if (!strEQ(s, "disconnect")) + goto unknown; + disconnect = 1; + break; + default: + unknown: + Perl_croak(aTHX_ "OS2::pipeCntl(): unknown argument: `%s'", s); + break; + } + + if (items == 3 && !connect) + Perl_croak(aTHX_ "OS2::pipeCntl(): no wait argument for `%s'", s); + + XSprePUSH; /* Do not need arguments any more */ + if (disconnect) { + os2cp_croak(DosDisConnectNPipe(hpipe), "OS2::pipeCntl(): DosDisConnectNPipe()"); + PerlIO_clearerr(perlio); + } + if (connect) { + if (!connectNPipe(hpipe, wait , 1, 0)) + XSRETURN_IV(-1); + } + if (query) { + ULONG flags; + + os2cp_croak(DosQueryNPHState(hpipe, &flags), "DosQueryNPHState()"); + XSRETURN_UV(flags); + } + if (peek || state || info) { + ULONG BytesRead, PipeState; + AVAILDATA BytesAvail; + + os2cp_croak( DosPeekNPipe(hpipe, NULL, 0, &BytesRead, &BytesAvail, + &PipeState), "DosPeekNPipe() for state"); + if (state) { + EXTEND(SP, 3); + mPUSHu(PipeState); + /* Bytes (available/in-message) */ + mPUSHi(BytesAvail.cbpipe); + mPUSHi(BytesAvail.cbmessage); + XSRETURN(3); + } else if (info) { + /* L S S C C C/Z* + ID of the (remote) computer + buffers (out/in) + instances (max/actual) + */ + struct pipe_info_t { + ULONG id; /* char id[4]; */ + PIPEINFO pInfo; + char buf[512]; + } b; + int size; + + os2cp_croak( DosQueryNPipeInfo(hpipe, 1, &b.pInfo, sizeof(b) - STRUCT_OFFSET(struct pipe_info_t, pInfo)), + "DosQueryNPipeInfo(1)"); + os2cp_croak( DosQueryNPipeInfo(hpipe, 2, &b.id, sizeof(b.id)), + "DosQueryNPipeInfo(2)"); + size = b.pInfo.cbName; + /* Trailing 0 is included in cbName - undocumented; so + one should always extract with Z* */ + if (size) /* name length 254 or less */ + size--; + else + size = strlen(b.pInfo.szName); + EXTEND(SP, 6); + mPUSHp(b.pInfo.szName, size); + mPUSHu(b.id); + mPUSHi(b.pInfo.cbOut); + mPUSHi(b.pInfo.cbIn); + mPUSHi(b.pInfo.cbMaxInst); + mPUSHi(b.pInfo.cbCurInst); + XSRETURN(6); + } else if (BytesAvail.cbpipe == 0) { + XSRETURN_NO; + } else { + SV *tmp = NEWSV(914, BytesAvail.cbpipe); + char *s = SvPVX(tmp); + + sv_2mortal(tmp); + os2cp_croak( DosPeekNPipe(hpipe, s, BytesAvail.cbpipe, &BytesRead, + &BytesAvail, &PipeState), "DosPeekNPipe()"); + SvCUR_set(tmp, BytesRead); + *SvEND(tmp) = 0; + SvPOK_on(tmp); + XSprePUSH; PUSHs(tmp); + XSRETURN(1); + } + } + if (message > -1) { + ULONG oflags, flags; + + os2cp_croak(DosQueryNPHState(hpipe, &oflags), "DosQueryNPHState()"); + /* DosSetNPHState fails if more bits than NP_NOWAIT|NP_READMODE_MESSAGE */ + oflags &= (NP_NOWAIT | NP_READMODE_MESSAGE); + flags = (oflags & NP_NOWAIT) + | (message ? NP_READMODE_MESSAGE : NP_READMODE_BYTE); + if (flags != oflags) + os2cp_croak(DosSetNPHState(hpipe, flags), "DosSetNPHState()"); + } } XSRETURN_YES; } @@ -4442,65 +4442,65 @@ XS(XS_OS2_pipeCntl) NO_OUTPUT ULONG DosOpen(PCSZ pszFileName, OUTLIST HFILE hFile, OUTLIST ULONG ulAction, ULONG ulOpenFlags, ULONG ulOpenMode = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ULONG ulAttribute = FILE_NORMAL, ULONG ulFileSize = 0, PEAOP2 pEABuf = NULL); PREINIT: - ULONG rc; + ULONG rc; C_ARGS: - pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf + pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf POSTCALL: - if (CheckOSError(RETVAL)) - croak_with_os2error("OS2::open() error"); + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::open() error"); */ XS(XS_OS2_open); /* prototype to pass -Wmissing-prototypes */ XS(XS_OS2_open) { dXSARGS; if (items < 2 || items > 6) - Perl_croak(aTHX_ "Usage: OS2::open(pszFileName, ulOpenMode, ulOpenFlags= OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ulAttribute= FILE_NORMAL, ulFileSize= 0, pEABuf= NULL)"); + Perl_croak(aTHX_ "Usage: OS2::open(pszFileName, ulOpenMode, ulOpenFlags= OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW, ulAttribute= FILE_NORMAL, ulFileSize= 0, pEABuf= NULL)"); { #line 39 "pipe.xs" - ULONG rc; + ULONG rc; #line 113 "pipe.c" - ULONG RETVAL; - PCSZ pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL ); - HFILE hFile; - ULONG ulAction; - ULONG ulOpenMode = (ULONG)SvUV(ST(1)); - ULONG ulOpenFlags; - ULONG ulAttribute; - ULONG ulFileSize; - PEAOP2 pEABuf; - - if (items < 3) - ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW; - else { - ulOpenFlags = (ULONG)SvUV(ST(2)); - } - - if (items < 4) - ulAttribute = FILE_NORMAL; - else { - ulAttribute = (ULONG)SvUV(ST(3)); - } - - if (items < 5) - ulFileSize = 0; - else { - ulFileSize = (ULONG)SvUV(ST(4)); - } - - if (items < 6) - pEABuf = NULL; - else { - pEABuf = (PEAOP2)SvUV(ST(5)); - } - - RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf); - if (CheckOSError(RETVAL)) - croak_with_os2error("OS2::open() error"); - XSprePUSH; EXTEND(SP,2); - PUSHs(sv_newmortal()); - sv_setuv(ST(0), (UV)hFile); - PUSHs(sv_newmortal()); - sv_setuv(ST(1), (UV)ulAction); + ULONG RETVAL; + PCSZ pszFileName = ( SvOK(ST(0)) ? (PCSZ)SvPV_nolen(ST(0)) : NULL ); + HFILE hFile; + ULONG ulAction; + ULONG ulOpenMode = (ULONG)SvUV(ST(1)); + ULONG ulOpenFlags; + ULONG ulAttribute; + ULONG ulFileSize; + PEAOP2 pEABuf; + + if (items < 3) + ulOpenFlags = OPEN_ACTION_OPEN_IF_EXISTS | OPEN_ACTION_FAIL_IF_NEW; + else { + ulOpenFlags = (ULONG)SvUV(ST(2)); + } + + if (items < 4) + ulAttribute = FILE_NORMAL; + else { + ulAttribute = (ULONG)SvUV(ST(3)); + } + + if (items < 5) + ulFileSize = 0; + else { + ulFileSize = (ULONG)SvUV(ST(4)); + } + + if (items < 6) + pEABuf = NULL; + else { + pEABuf = (PEAOP2)SvUV(ST(5)); + } + + RETVAL = DosOpen(pszFileName, &hFile, &ulAction, ulFileSize, ulAttribute, ulOpenFlags, ulOpenMode, pEABuf); + if (CheckOSError(RETVAL)) + croak_with_os2error("OS2::open() error"); + XSprePUSH; EXTEND(SP,2); + PUSHs(sv_newmortal()); + sv_setuv(ST(0), (UV)hFile); + PUSHs(sv_newmortal()); + sv_setuv(ST(1), (UV)ulAction); } XSRETURN(2); } @@ -4510,15 +4510,15 @@ Xs_OS2_init(pTHX) { char *file = __FILE__; { - GV *gv; + GV *gv; - if (_emx_env & 0x200) { /* OS/2 */ + if (_emx_env & 0x200) { /* OS/2 */ newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file); newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file); newXS("OS2::extLibpath", XS_Cwd_extLibpath, file); newXS("OS2::extLibpath_set", XS_Cwd_extLibpath_set, file); - } + } newXS("OS2::Error", XS_OS2_Error, file); newXS("OS2::Errors2Drive", XS_OS2_Errors2Drive, file); newXS("OS2::SysInfo", XS_OS2_SysInfo, file); @@ -4559,33 +4559,33 @@ Xs_OS2_init(pTHX) newXSproto("OS2::pipe", XS_OS2_pipe, file, "$$;$$$$$$"); newXSproto("OS2::pipeCntl", XS_OS2_pipeCntl, file, "$$;$"); newXSproto("OS2::open", XS_OS2_open, file, "$$;$$$$"); - gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); - GvMULTI_on(gv); + gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); + GvMULTI_on(gv); #ifdef PERL_IS_AOUT - sv_setiv(GvSV(gv), 1); + sv_setiv(GvSV(gv), 1); #endif - gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV); - GvMULTI_on(gv); + gv = gv_fetchpv("OS2::is_static", TRUE, SVt_PV); + GvMULTI_on(gv); #ifdef PERL_IS_AOUT - sv_setiv(GvSV(gv), 1); + sv_setiv(GvSV(gv), 1); #endif - gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV); - GvMULTI_on(gv); - sv_setiv(GvSV(gv), exe_is_aout()); - gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV); - GvMULTI_on(gv); - sv_setiv(GvSV(gv), _emx_rev); - sv_setpv(GvSV(gv), _emx_vprt); - SvIOK_on(GvSV(gv)); - gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV); - GvMULTI_on(gv); - sv_setiv(GvSV(gv), _emx_env); - gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV); - GvMULTI_on(gv); - sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor); - gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV); - GvMULTI_on(gv); - sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */ + gv = gv_fetchpv("OS2::can_fork", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setiv(GvSV(gv), exe_is_aout()); + gv = gv_fetchpv("OS2::emx_rev", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setiv(GvSV(gv), _emx_rev); + sv_setpv(GvSV(gv), _emx_vprt); + SvIOK_on(GvSV(gv)); + gv = gv_fetchpv("OS2::emx_env", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setiv(GvSV(gv), _emx_env); + gv = gv_fetchpv("OS2::os_ver", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setnv(GvSV(gv), _osmajor + 0.001 * _osminor); + gv = gv_fetchpv("OS2::nsyserror", TRUE, SVt_PV); + GvMULTI_on(gv); + sv_setiv(GvSV(gv), 1); /* DEFAULT: Show number on syserror */ } return 0; } @@ -4604,13 +4604,13 @@ my_emx_init(void *layout) { /* Can't just call emx_init(), since it moves the stack pointer */ /* It also busts a lot of registers, so be extra careful */ __asm__( "pushf\n" - "pusha\n" - "movl %%esp, %1\n" - "push %0\n" - "call __emx_init\n" - "movl %1, %%esp\n" - "popa\n" - "popf\n" : : "r" (layout), "m" (old_esp) ); + "pusha\n" + "movl %%esp, %1\n" + "push %0\n" + "call __emx_init\n" + "movl %1, %%esp\n" + "popa\n" + "popf\n" : : "r" (layout), "m" (old_esp) ); } struct layout_table_t { @@ -4639,11 +4639,11 @@ my_os_version() { /* Can't just call __os_version(), since it does not follow C calling convention: it busts a lot of registers, so be extra careful */ __asm__( "pushf\n" - "pusha\n" - "call ___os_version\n" - "movl %%eax, %0\n" - "popa\n" - "popf\n" : "=m" (osv_res) ); + "pusha\n" + "call ___os_version\n" + "movl %%eax, %0\n" + "popa\n" + "popf\n" : "=m" (osv_res) ); return osv_res; } @@ -4661,9 +4661,9 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) char buf[512]; static struct layout_table_t layout_table; struct { - char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */ - double alignment1; - EXCEPTIONREGISTRATIONRECORD xreg; + char buf[48*1024]; /* _emx_init() requires 32K, cmd.exe has 64K only */ + double alignment1; + EXCEPTIONREGISTRATIONRECORD xreg; } *newstack; char *s; @@ -4677,23 +4677,23 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) oldstackend = tib->tib_pstacklimit; if ( (char*)&s < (char*)oldstack + 4*1024 - || (char *)oldstackend < (char*)oldstack + 52*1024 ) - early_error("It is a lunacy to try to run EMX Perl ", - "with less than 64K of stack;\r\n", - " at least with non-EMX starter...\r\n"); + || (char *)oldstackend < (char*)oldstack + 52*1024 ) + early_error("It is a lunacy to try to run EMX Perl ", + "with less than 64K of stack;\r\n", + " at least with non-EMX starter...\r\n"); /* Minimize the damage to the stack via reducing the size of argv. */ if (flags & FORCE_EMX_INIT_CONTRACT_ARGV) { - pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */ - pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */ + pib->pib_pchcmd = "\0\0"; /* Need 3 concatenated strings */ + pib->pib_pchcmd = "\0"; /* Ended by an extra \0. */ } newstack = alloca(sizeof(*newstack)); /* Emulate the stack probe */ s = ((char*)newstack) + sizeof(*newstack); while (s > (char*)newstack) { - s[-1] = 0; - s -= 4096; + s[-1] = 0; + s -= 4096; } /* Reassigning stack is documented to work */ @@ -4707,38 +4707,38 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) Check whether it is inside the new stack. */ buf[0] = 0; if (tib->tib_pexchain >= tib->tib_pstacklimit - || tib->tib_pexchain < tib->tib_pstack) { - error = 1; - sprintf(buf, - "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n", - (unsigned long)tib->tib_pstack, - (unsigned long)tib->tib_pexchain, - (unsigned long)tib->tib_pstacklimit); - goto finish; + || tib->tib_pexchain < tib->tib_pstack) { + error = 1; + sprintf(buf, + "panic: ExceptionHandler misplaced: not %#lx <= %#lx < %#lx\n", + (unsigned long)tib->tib_pstack, + (unsigned long)tib->tib_pexchain, + (unsigned long)tib->tib_pstacklimit); + goto finish; } if (tib->tib_pexchain != &(newstack->xreg)) { - sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n", - (unsigned long)tib->tib_pexchain, - (unsigned long)&(newstack->xreg)); + sprintf(buf, "ExceptionHandler misplaced: %#lx != %#lx\n", + (unsigned long)tib->tib_pexchain, + (unsigned long)&(newstack->xreg)); } rc = DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)tib->tib_pexchain); if (rc) - sprintf(buf + strlen(buf), - "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc); + sprintf(buf + strlen(buf), + "warning: DosUnsetExceptionHandler rc=%#lx=%lu\n", rc, rc); if (preg) { - /* ExceptionRecords should be on stack, in a correct order. Sigh... */ - preg->prev_structure = 0; - preg->ExceptionHandler = _emx_exception; - rc = DosSetExceptionHandler(preg); - if (rc) { - sprintf(buf + strlen(buf), - "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc); - DosWrite(2, buf, strlen(buf), &out); - emx_exception_init = 1; /* Do it around spawn*() calls */ - } + /* ExceptionRecords should be on stack, in a correct order. Sigh... */ + preg->prev_structure = 0; + preg->ExceptionHandler = _emx_exception; + rc = DosSetExceptionHandler(preg); + if (rc) { + sprintf(buf + strlen(buf), + "warning: DosSetExceptionHandler rc=%#lx=%lu\n", rc, rc); + DosWrite(2, buf, strlen(buf), &out); + emx_exception_init = 1; /* Do it around spawn*() calls */ + } } else - emx_exception_init = 1; /* Do it around spawn*() calls */ + emx_exception_init = 1; /* Do it around spawn*() calls */ finish: /* Restore the damage */ @@ -4748,16 +4748,16 @@ force_init_emx_runtime(EXCEPTIONREGISTRATIONRECORD *preg, ULONG flags) tib->tib_pstack = oldstack; emx_runtime_init = 1; if (buf[0]) - DosWrite(2, buf, strlen(buf), &out); + DosWrite(2, buf, strlen(buf), &out); if (error) - exit(56); + exit(56); } static void jmp_out_of_atexit(void) { if (longjmp_at_exit) - longjmp(at_exit_buf, 1); + longjmp(at_exit_buf, 1); } extern void _CRT_term(void); @@ -4766,34 +4766,34 @@ void Perl_OS2_term(void **p, int exitstatus, int flags) { if (!emx_runtime_secondary) - return; + return; /* The principal executable is not running the same CRTL, so there is nobody to shutdown *this* CRTL except us... */ if (flags & FORCE_EMX_DEINIT_EXIT) { - if (p && !emx_exception_init) - DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); - /* Do not run the executable's CRTL's termination routines */ - exit(exitstatus); /* Run at-exit, flush buffers, etc */ + if (p && !emx_exception_init) + DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); + /* Do not run the executable's CRTL's termination routines */ + exit(exitstatus); /* Run at-exit, flush buffers, etc */ } /* Run at-exit list, and jump out at the end */ if ((flags & FORCE_EMX_DEINIT_RUN_ATEXIT) && !setjmp(at_exit_buf)) { - longjmp_at_exit = 1; - exit(exitstatus); /* The first pass through "if" */ + longjmp_at_exit = 1; + exit(exitstatus); /* The first pass through "if" */ } /* Get here if we managed to jump out of exit(), or did not run atexit. */ longjmp_at_exit = 0; /* Maybe exit() is called again? */ #if 0 /* _atexit_n is not exported */ if (flags & FORCE_EMX_DEINIT_RUN_ATEXIT) - _atexit_n = 0; /* Remove the atexit() handlers */ + _atexit_n = 0; /* Remove the atexit() handlers */ #endif /* Will segfault on program termination if we leave this dangling... */ if (p && !emx_exception_init) - DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); + DosUnsetExceptionHandler((EXCEPTIONREGISTRATIONRECORD *)p); /* Typically there is no need to do this, done from _DLL_InitTerm() */ if (flags & FORCE_EMX_DEINIT_CRT_TERM) - _CRT_term(); /* Flush buffers, etc. */ + _CRT_term(); /* Flush buffers, etc. */ /* Now it is a good time to call exit() in the caller's CRTL... */ } @@ -4809,11 +4809,11 @@ check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) static int emx_init_done = 0; /* If _environ is not set, this code sits in a DLL which - uses a CRT DLL which not compatible with the executable's - CRT library. Some parts of the DLL are not initialized. + uses a CRT DLL which not compatible with the executable's + CRT library. Some parts of the DLL are not initialized. */ if (_environ != NULL) - return; /* Properly initialized */ + return; /* Properly initialized */ /* It is not DOS, so we may use OS/2 API now */ /* Some data we manipulate is static; protect ourselves from @@ -4822,92 +4822,92 @@ check_emx_runtime(char **env, EXCEPTIONREGISTRATIONRECORD *preg) rc1 = DosEnterCritSec(); if (!hmtx_emx_init) - rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/ + rc = DosCreateMutexSem(NULL, &hmtx_emx_init, 0, TRUE); /*Create owned*/ else - maybe_inited = 1; + maybe_inited = 1; if (rc != NO_ERROR) - hmtx_emx_init = NULLHANDLE; + hmtx_emx_init = NULLHANDLE; if (rc1 == NO_ERROR) - DosExitCritSec(); + DosExitCritSec(); DosExitMustComplete(&count); while (maybe_inited) { /* Other thread did or is doing the same now */ - if (emx_init_done) - return; - rc = DosRequestMutexSem(hmtx_emx_init, - (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */ - if (rc == ERROR_INTERRUPT) - continue; - if (rc != NO_ERROR) { - char buf[80]; - ULONG out; - - sprintf(buf, - "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc); - DosWrite(2, buf, strlen(buf), &out); - return; - } - DosReleaseMutexSem(hmtx_emx_init); - return; + if (emx_init_done) + return; + rc = DosRequestMutexSem(hmtx_emx_init, + (ULONG) SEM_INDEFINITE_WAIT); /* Timeout (none) */ + if (rc == ERROR_INTERRUPT) + continue; + if (rc != NO_ERROR) { + char buf[80]; + ULONG out; + + sprintf(buf, + "panic: EMX backdoor init: DosRequestMutexSem error: %lu=%#lx\n", rc, rc); + DosWrite(2, buf, strlen(buf), &out); + return; + } + DosReleaseMutexSem(hmtx_emx_init); + return; } /* If the executable does not use EMX.DLL, EMX.DLL is not completely - initialized either. Uninitialized EMX.DLL returns 0 in the low - nibble of __os_version(). */ + initialized either. Uninitialized EMX.DLL returns 0 in the low + nibble of __os_version(). */ v_emx = my_os_version(); /* _osmajor and _osminor are normally set in _DLL_InitTerm of CRT DLL - (=>_CRT_init=>_entry2) via a call to __os_version(), then - reset when the EXE initialization code calls _text=>_init=>_entry2. - The first time they are wrongly set to 0; the second time the - EXE initialization code had already called emx_init=>initialize1 - which correctly set version_major, version_minor used by - __os_version(). */ + (=>_CRT_init=>_entry2) via a call to __os_version(), then + reset when the EXE initialization code calls _text=>_init=>_entry2. + The first time they are wrongly set to 0; the second time the + EXE initialization code had already called emx_init=>initialize1 + which correctly set version_major, version_minor used by + __os_version(). */ v_crt = (_osmajor | _osminor); if ((_emx_env & 0x200) && !(v_emx & 0xFFFF)) { /* OS/2, EMX uninit. */ - force_init_emx_runtime( preg, - FORCE_EMX_INIT_CONTRACT_ARGV - | FORCE_EMX_INIT_INSTALL_ATEXIT ); - emx_wasnt_initialized = 1; - /* Update CRTL data basing on now-valid EMX runtime data */ - if (!v_crt) { /* The only wrong data are the versions. */ - v_emx = my_os_version(); /* *Now* it works */ - *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */ - *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF; - } + force_init_emx_runtime( preg, + FORCE_EMX_INIT_CONTRACT_ARGV + | FORCE_EMX_INIT_INSTALL_ATEXIT ); + emx_wasnt_initialized = 1; + /* Update CRTL data basing on now-valid EMX runtime data */ + if (!v_crt) { /* The only wrong data are the versions. */ + v_emx = my_os_version(); /* *Now* it works */ + *(unsigned char *)&_osmajor = v_emx & 0xFF; /* Cast out const */ + *(unsigned char *)&_osminor = (v_emx>>8) & 0xFF; + } } emx_runtime_secondary = 1; /* if (flags & FORCE_EMX_INIT_INSTALL_ATEXIT) */ atexit(jmp_out_of_atexit); /* Allow run of atexit() w/o exit() */ if (env == NULL) { /* Fetch from the process info block */ - int c = 0; - PPIB pib; - PTIB tib; - char *e, **ep; - - DosGetInfoBlocks(&tib, &pib); - e = pib->pib_pchenv; - while (*e) { /* Get count */ - c++; - e = e + strlen(e) + 1; - } - Newx(env, c + 1, char*); - ep = env; - e = pib->pib_pchenv; - while (c--) { - *ep++ = e; - e = e + strlen(e) + 1; - } - *ep = NULL; + int c = 0; + PPIB pib; + PTIB tib; + char *e, **ep; + + DosGetInfoBlocks(&tib, &pib); + e = pib->pib_pchenv; + while (*e) { /* Get count */ + c++; + e = e + strlen(e) + 1; + } + Newx(env, c + 1, char*); + ep = env; + e = pib->pib_pchenv; + while (c--) { + *ep++ = e; + e = e + strlen(e) + 1; + } + *ep = NULL; } _environ = _org_environ = env; emx_init_done = 1; if (hmtx_emx_init) - DosReleaseMutexSem(hmtx_emx_init); + DosReleaseMutexSem(hmtx_emx_init); } #define ENTRY_POINT 0x10000 @@ -4917,16 +4917,16 @@ exe_is_aout(void) { struct layout_table_t *layout; if (emx_wasnt_initialized) - return 0; + return 0; /* Now we know that the principal executable is an EMX application - unless somebody did already play with delayed initialization... */ /* With EMX applications to determine whether it is AOUT one needs to examine the start of the executable to find "layout" */ if ( *(unsigned char*)ENTRY_POINT != 0x68 /* PUSH n */ - || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */ - || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */ - || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */ - return 0; /* ! EMX executable */ + || *(unsigned char*)(ENTRY_POINT+5) != 0xe8 /* CALL */ + || *(unsigned char*)(ENTRY_POINT+10) != 0xeb /* JMP */ + || *(unsigned char*)(ENTRY_POINT+12) != 0xe8) /* CALL */ + return 0; /* ! EMX executable */ /* Fix alignment */ Copy((char*)(ENTRY_POINT+1), &layout, 1, struct layout_table_t*); return !(layout->flags & 2); @@ -4952,25 +4952,25 @@ Perl_OS2_init3(char **env, void **preg, int flags) settmppath(); OS2_Perl_data.xs_init = &Xs_OS2_init; if (perl_sh_installed) { - int l = strlen(perl_sh_installed); + int l = strlen(perl_sh_installed); - Newx(PL_sh_path, l + 1, char); - memcpy(PL_sh_path, perl_sh_installed, l + 1); + Newx(PL_sh_path, l + 1, char); + memcpy(PL_sh_path, perl_sh_installed, l + 1); } else if ( (shell = PerlEnv_getenv("PERL_SH_DRIVE")) ) { - Newx(PL_sh_path, strlen(SH_PATH) + 1, char); - strcpy(PL_sh_path, SH_PATH); - PL_sh_path[0] = shell[0]; + Newx(PL_sh_path, strlen(SH_PATH) + 1, char); + strcpy(PL_sh_path, SH_PATH); + PL_sh_path[0] = shell[0]; } else if ( (shell = PerlEnv_getenv("PERL_SH_DIR")) ) { - int l = strlen(shell), i; - - while (l && (shell[l-1] == '/' || shell[l-1] == '\\')) - l--; - Newx(PL_sh_path, l + 8, char); - strncpy(PL_sh_path, shell, l); - strcpy(PL_sh_path + l, "/sh.exe"); - for (i = 0; i < l; i++) { - if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/'; - } + int l = strlen(shell), i; + + while (l && (shell[l-1] == '/' || shell[l-1] == '\\')) + l--; + Newx(PL_sh_path, l + 8, char); + strncpy(PL_sh_path, shell, l); + strcpy(PL_sh_path + l, "/sh.exe"); + for (i = 0; i < l; i++) { + if (PL_sh_path[i] == '\\') PL_sh_path[i] = '/'; + } } MUTEX_INIT(&start_thread_mutex); MUTEX_INIT(&perlos2_state_mutex); @@ -4984,19 +4984,19 @@ Perl_OS2_init3(char **env, void **preg, int flags) else rc = fill_extLibpath(0, PerlEnv_getenv("PERL_PRE_BEGINLIBPATH"), PerlEnv_getenv("PERL_POST_BEGINLIBPATH"), 0, "PERL_(PRE/POST)_BEGINLIBPATH"); if (!rc) { - s = PerlEnv_getenv("PERL_ENDLIBPATH"); - if (s) - rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH"); - else - rc = fill_extLibpath(1, PerlEnv_getenv("PERL_PRE_ENDLIBPATH"), PerlEnv_getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH"); + s = PerlEnv_getenv("PERL_ENDLIBPATH"); + if (s) + rc = fill_extLibpath(1, s, NULL, 1, "PERL_ENDLIBPATH"); + else + rc = fill_extLibpath(1, PerlEnv_getenv("PERL_PRE_ENDLIBPATH"), PerlEnv_getenv("PERL_POST_ENDLIBPATH"), 0, "PERL_(PRE/POST)_ENDLIBPATH"); } if (rc) { - char buf[1024]; + char buf[1024]; - snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n", - os2error(rc)); - DosWrite(2, buf, strlen(buf), &rc); - exit(2); + snprintf(buf, sizeof buf, "Error setting BEGIN/ENDLIBPATH: %s\n", + os2error(rc)); + DosWrite(2, buf, strlen(buf), &rc); + exit(2); } _emxload_env("PERL_EMXLOAD_SECS"); @@ -5011,10 +5011,10 @@ fd_ok(int fd) if (!(_emx_env & 0x200)) return 1; /* not OS/2. */ if (fd >= max_fh) { /* Renew */ - LONG delta = 0; + LONG delta = 0; - if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */ - return 1; + if (DosSetRelMaxFH(&delta, &max_fh)) /* Assume it OK??? */ + return 1; } return fd < max_fh; } @@ -5024,7 +5024,7 @@ int dup2(int from, int to) { if (fd_ok(from < to ? to : from)) - return _dup2(from, to); + return _dup2(from, to); errno = EBADF; return -1; } @@ -5033,7 +5033,7 @@ int dup(int from) { if (fd_ok(from)) - return _dup(from); + return _dup(from); errno = EBADF; return -1; } @@ -5050,9 +5050,9 @@ my_tmpnam (char *str) ENV_LOCK; tpath = tempnam(p, "pltmp"); if (str && tpath) { - strcpy(str, tpath); + strcpy(str, tpath); ENV_UNLOCK; - return str; + return str; } ENV_UNLOCK; return tpath; @@ -5065,10 +5065,10 @@ my_tmpfile () stat(".", &s); if (s.st_mode & S_IWOTH) { - return tmpfile(); + return tmpfile(); } return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but - grants TMP. */ + grants TMP. */ } #undef rmdir @@ -5085,17 +5085,17 @@ my_rmdir (__const__ char *s) int rc; if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */ - if (l >= sizeof b) - Newx(buf, l + 1, char); - strcpy(buf,s); - while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\')) - l--; - buf[l] = 0; - s = buf; + if (l >= sizeof b) + Newx(buf, l + 1, char); + strcpy(buf,s); + while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\')) + l--; + buf[l] = 0; + s = buf; } rc = rmdir(s); if (b != buf) - Safefree(buf); + Safefree(buf); return rc; } @@ -5110,17 +5110,17 @@ my_mkdir (__const__ char *s, long perm) int rc; if (s[l-1] == '/' || s[l-1] == '\\') { /* EMX mkdir fails... */ - if (l >= sizeof b) - Newx(buf, l + 1, char); - strcpy(buf,s); - while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\')) - l--; - buf[l] = 0; - s = buf; + if (l >= sizeof b) + Newx(buf, l + 1, char); + strcpy(buf,s); + while (l > 1 && (s[l-1] == '/' || s[l-1] == '\\')) + l--; + buf[l] = 0; + s = buf; } rc = mkdir(s, perm); if (b != buf) - Safefree(buf); + Safefree(buf); return rc; } @@ -5141,9 +5141,9 @@ my_flock(int handle, int o) if (use_my_flock == -1) { char *s = PerlEnv_getenv("USE_PERL_FLOCK"); if (s) - use_my_flock = atoi(s); + use_my_flock = atoi(s); else - use_my_flock = 1; + use_my_flock = 1; } MUTEX_UNLOCK(&perlos2_state_mutex); } @@ -5247,9 +5247,9 @@ use_my_pwent(void) if (_my_pwent == -1) { char *s = PerlEnv_getenv("USE_PERL_PWENT"); if (s) - _my_pwent = atoi(s); + _my_pwent = atoi(s); else - _my_pwent = 1; + _my_pwent = 1; } return _my_pwent; } @@ -5318,11 +5318,11 @@ passw_wrap(struct passwd *p) char *s; if (!p || (p->pw_passwd && *p->pw_passwd)) /* Not a dangerous password */ - return p; + return p; pw = *p; s = PerlEnv_getenv("PW_PASSWD"); if (!s) - s = (char*)pw_p; /* Make match impossible */ + s = (char*)pw_p; /* Make match impossible */ pw.pw_passwd = s; @@ -5385,51 +5385,51 @@ int fork_with_resources() #endif { /* Reload loaded-on-demand DLLs */ - struct dll_handle_t *dlls = dll_handles; - - while (dlls->modname) { - char dllname[260], fail[260]; - ULONG rc; - - if (!dlls->handle) { /* Was not loaded */ - dlls++; - continue; - } - /* It was loaded in the parent. We need to reload it. */ - - rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname); - if (rc) { - Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx", - dlls->modname, (int)dlls->handle, rc, rc); - dlls++; - continue; - } - rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle); - if (rc) - Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'", - dllname, fail); - dlls++; - } + struct dll_handle_t *dlls = dll_handles; + + while (dlls->modname) { + char dllname[260], fail[260]; + ULONG rc; + + if (!dlls->handle) { /* Was not loaded */ + dlls++; + continue; + } + /* It was loaded in the parent. We need to reload it. */ + + rc = DosQueryModuleName(dlls->handle, sizeof(dllname), dllname); + if (rc) { + Perl_warn_nocontext("Can't find DLL name for the module `%s' by the handle %d, rc=%lu=%#lx", + dlls->modname, (int)dlls->handle, rc, rc); + dlls++; + continue; + } + rc = DosLoadModule(fail, sizeof fail, dllname, &dlls->handle); + if (rc) + Perl_warn_nocontext("Can't load DLL `%s', possible problematic module `%s'", + dllname, fail); + dlls++; + } } { /* Support message queue etc. */ - os2_mytype = my_type(); - /* Apparently, subprocesses (in particular, fork()) do not - inherit the morphed state, so os2_mytype is the same as - os2_mytype_ini. */ - - if (Perl_os2_initial_mode != -1 - && Perl_os2_initial_mode != os2_mytype) { - /* XXXX ??? */ - } + os2_mytype = my_type(); + /* Apparently, subprocesses (in particular, fork()) do not + inherit the morphed state, so os2_mytype is the same as + os2_mytype_ini. */ + + if (Perl_os2_initial_mode != -1 + && Perl_os2_initial_mode != os2_mytype) { + /* XXXX ??? */ + } } if (Perl_HAB_set) - (void)_obtain_Perl_HAB; + (void)_obtain_Perl_HAB; if (Perl_hmq_refcnt) { - if (my_type() != 3) - my_type_set(3); - Create_HMQ(Perl_hmq_servers != 0, - "Cannot create a message queue on fork"); + if (my_type() != 3) + my_type_set(3); + Create_HMQ(Perl_hmq_servers != 0, + "Cannot create a message queue on fork"); } /* We may have loaded some modules */ @@ -5454,7 +5454,7 @@ myDosGetInfoSeg(PGINFOSEG *pGlobal, PLINFOSEG *pLocal) _THUNK_FLAT (&lSel); _THUNK_CALL (Dos16GetInfoSeg))); if (rc) - return rc; + return rc; *pGlobal = MAKEPGINFOSEG(gSel); *pLocal = MAKEPLINFOSEG(lSel); return rc; diff --git a/os2/os2ish.h b/os2/os2ish.h index e209fb5605..1acc2765c2 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -117,68 +117,68 @@ extern int rc; #define MUTEX_INIT(m) \ STMT_START { \ - int rc; \ - if ((rc = _rmutex_create(m,0))) \ - Perl_croak_nocontext("panic: MUTEX_INIT: rc=%i", rc); \ + int rc; \ + if ((rc = _rmutex_create(m,0))) \ + Perl_croak_nocontext("panic: MUTEX_INIT: rc=%i", rc); \ } STMT_END #define MUTEX_LOCK(m) \ STMT_START { \ - int rc; \ - if ((rc = _rmutex_request(m,_FMR_IGNINT))) \ - Perl_croak_nocontext("panic: MUTEX_LOCK: rc=%i", rc); \ + int rc; \ + if ((rc = _rmutex_request(m,_FMR_IGNINT))) \ + Perl_croak_nocontext("panic: MUTEX_LOCK: rc=%i", rc); \ } STMT_END #define MUTEX_UNLOCK(m) \ STMT_START { \ - int rc; \ - if ((rc = _rmutex_release(m))) \ - Perl_croak_nocontext("panic: MUTEX_UNLOCK: rc=%i", rc); \ + int rc; \ + if ((rc = _rmutex_release(m))) \ + Perl_croak_nocontext("panic: MUTEX_UNLOCK: rc=%i", rc); \ } STMT_END #define MUTEX_DESTROY(m) \ STMT_START { \ - int rc; \ - if ((rc = _rmutex_close(m))) \ - Perl_croak_nocontext("panic: MUTEX_DESTROY: rc=%i", rc); \ + int rc; \ + if ((rc = _rmutex_close(m))) \ + Perl_croak_nocontext("panic: MUTEX_DESTROY: rc=%i", rc); \ } STMT_END #define COND_INIT(c) \ STMT_START { \ - int rc; \ - if ((rc = DosCreateEventSem(NULL,c,0,0))) \ - Perl_croak_nocontext("panic: COND_INIT: rc=%i", rc); \ + int rc; \ + if ((rc = DosCreateEventSem(NULL,c,0,0))) \ + Perl_croak_nocontext("panic: COND_INIT: rc=%i", rc); \ } STMT_END #define COND_SIGNAL(c) \ STMT_START { \ - int rc; \ - if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ - Perl_croak_nocontext("panic: COND_SIGNAL, rc=%ld", rc); \ + int rc; \ + if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ + Perl_croak_nocontext("panic: COND_SIGNAL, rc=%ld", rc); \ } STMT_END #define COND_BROADCAST(c) \ STMT_START { \ - int rc; \ - if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ - Perl_croak_nocontext("panic: COND_BROADCAST, rc=%i", rc); \ + int rc; \ + if ((rc = DosPostEventSem(*(c))) && rc != OS2_ERROR_ALREADY_POSTED)\ + Perl_croak_nocontext("panic: COND_BROADCAST, rc=%i", rc); \ } STMT_END /* #define COND_WAIT(c, m) \ STMT_START { \ - if (WaitForSingleObject(*(c),INFINITE) == WAIT_FAILED) \ - Perl_croak_nocontext("panic: COND_WAIT"); \ + if (WaitForSingleObject(*(c),INFINITE) == WAIT_FAILED) \ + Perl_croak_nocontext("panic: COND_WAIT"); \ } STMT_END */ #define COND_WAIT(c, m) os2_cond_wait(c,m) #define COND_WAIT_win32(c, m) \ STMT_START { \ - int rc; \ - if ((rc = SignalObjectAndWait(*(m),*(c),INFINITE,FALSE))) \ - Perl_croak_nocontext("panic: COND_WAIT"); \ - else \ - MUTEX_LOCK(m); \ + int rc; \ + if ((rc = SignalObjectAndWait(*(m),*(c),INFINITE,FALSE))) \ + Perl_croak_nocontext("panic: COND_WAIT"); \ + else \ + MUTEX_LOCK(m); \ } STMT_END #define COND_DESTROY(c) \ STMT_START { \ - int rc; \ - if ((rc = DosCloseEventSem(*(c)))) \ - Perl_croak_nocontext("panic: COND_DESTROY, rc=%i", rc); \ + int rc; \ + if ((rc = DosCloseEventSem(*(c)))) \ + Perl_croak_nocontext("panic: COND_DESTROY, rc=%i", rc); \ } STMT_END /*#define THR ((struct thread *) TlsGetValue(PL_thr_key)) */ @@ -191,10 +191,10 @@ extern int rc; # define pthread_getspecific(k) (*(k)) # define pthread_setspecific(k,v) (*(k)=(v),0) # define pthread_key_create(keyp,flag) \ - ( DosAllocThreadLocalMemory(1,(unsigned long**)keyp) \ - ? Perl_croak_nocontext("LocalMemory"),1 \ - : 0 \ - ) + ( DosAllocThreadLocalMemory(1,(unsigned long**)keyp) \ + ? Perl_croak_nocontext("LocalMemory"),1 \ + : 0 \ + ) #endif /* USE_SLOW_THREAD_SPECIFIC */ #define pthread_key_delete(keyp) #define pthread_self() _gettid() @@ -204,7 +204,7 @@ extern int rc; int pthread_join(pthread_t tid, void **status); int pthread_detach(pthread_t tid); int pthread_create(pthread_t *tid, const pthread_attr_t *attr, - void *(*start_routine)(void*), void *arg); + void *(*start_routine)(void*), void *arg); #endif /* PTHREAD_INCLUDED */ #define THREADS_ELSEWHERE @@ -410,10 +410,10 @@ void *emx_realloc (void *, size_t); /* This guy is needed for quick stdstd */ #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) - /* Perl uses ungetc only with successful return */ + /* Perl uses ungetc only with successful return */ # define ungetc(c,fp) \ - (FILE_ptr(fp) > FILE_base(fp) && c == (int)*(FILE_ptr(fp) - 1) \ - ? (--FILE_ptr(fp), ++FILE_cnt(fp), (int)c) : ungetc(c,fp)) + (FILE_ptr(fp) > FILE_base(fp) && c == (int)*(FILE_ptr(fp) - 1) \ + ? (--FILE_ptr(fp), ++FILE_cnt(fp), (int)c) : ungetc(c,fp)) #endif #define PERLIO_IS_BINMODE_FD(fd) _PERLIO_IS_BINMODE_FD(fd) @@ -500,8 +500,8 @@ extern OS2_Perl_data_t OS2_Perl_data; #define set_Perl_HAB_f (OS2_Perl_flags |= Perl_HAB_set_f) #define set_Perl_HAB(h) (set_Perl_HAB_f, Perl_hab = h) #define _obtain_Perl_HAB (init_PMWIN_entries(), \ - Perl_hab = (*PMWIN_entries.Initialize)(0), \ - set_Perl_HAB_f, Perl_hab) + Perl_hab = (*PMWIN_entries.Initialize)(0), \ + set_Perl_HAB_f, Perl_hab) #define perl_hab_GET() (Perl_HAB_set ? Perl_hab : _obtain_Perl_HAB) #define Acquire_hab() perl_hab_GET() #define Perl_hmq ((HMQ)OS2_Perl_data.phmq) @@ -524,11 +524,11 @@ struct PMWIN_entries_t { unsigned long (*CreateMsgQueue)(unsigned long hab, long cmsg); int (*DestroyMsgQueue)(unsigned long hmq); int (*PeekMsg)(unsigned long hab, struct _QMSG *pqmsg, - unsigned long hwndFilter, unsigned long msgFilterFirst, - unsigned long msgFilterLast, unsigned long fl); + unsigned long hwndFilter, unsigned long msgFilterFirst, + unsigned long msgFilterLast, unsigned long fl); int (*GetMsg)(unsigned long hab, struct _QMSG *pqmsg, - unsigned long hwndFilter, unsigned long msgFilterFirst, - unsigned long msgFilterLast); + unsigned long hwndFilter, unsigned long msgFilterFirst, + unsigned long msgFilterLast); void * (*DispatchMsg)(unsigned long hab, struct _QMSG *pqmsg); unsigned long (*GetLastError)(unsigned long hab); unsigned long (*CancelShutdown)(unsigned long hmq, unsigned long fCancelAlways); @@ -543,7 +543,7 @@ void init_PMWIN_entries(void); #if _EMX_CRT_REV_ >= 60 # define os2_setsyserrno(rc) (Perl_rc = rc, errno = errno_isOS2_set, \ - _setsyserrno(rc)) + _setsyserrno(rc)) #else # define os2_setsyserrno(rc) (Perl_rc = rc, errno = errno_isOS2) #endif @@ -562,11 +562,11 @@ void init_PMWIN_entries(void); ((expr) ? : (CroakWinError(die,name1 name2), 0)) #define FillOSError(rc) (os2_setsyserrno(rc), \ - Perl_severity = SEVERITY_ERROR) + Perl_severity = SEVERITY_ERROR) #define WinError_2_Perl_rc \ ( init_PMWIN_entries(), \ - Perl_rc=(*PMWIN_entries.GetLastError)(perl_hab_GET()) ) + Perl_rc=(*PMWIN_entries.GetLastError)(perl_hab_GET()) ) /* Calling WinGetLastError() resets the error code of the current thread. Since for some Win* API return value 0 is normal, one needs to call @@ -576,9 +576,9 @@ void init_PMWIN_entries(void); /* At this moment init_PMWIN_entries() should be a nop (WinInitialize should be called already, right?), so we do not risk stepping over our own error */ #define FillWinError ( WinError_2_Perl_rc, \ - Perl_severity = ERRORIDSEV(Perl_rc), \ - Perl_rc = ERRORIDERROR(Perl_rc), \ - os2_setsyserrno(Perl_rc)) + Perl_severity = ERRORIDSEV(Perl_rc), \ + Perl_rc = ERRORIDERROR(Perl_rc), \ + os2_setsyserrno(Perl_rc)) #define STATIC_FILE_LENGTH 127 @@ -726,38 +726,38 @@ enum entries_ordinals { /* This flavor caches the procedure pointer (named as p__Win#name) locally */ #define DeclWinFuncByORD_CACHE(ret,name,o,at,args) \ - DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,0,1) + DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,0,1) /* This flavor may reset the last error before the call (if ret=0 may be OK) */ #define DeclWinFuncByORD_CACHE_resetError(ret,name,o,at,args) \ - DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,1,1) + DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,1,1) /* Two flavors below do the same as above, but do not auto-croak */ /* This flavor caches the procedure pointer (named as p__Win#name) locally */ #define DeclWinFuncByORD_CACHE_survive(ret,name,o,at,args) \ - DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,0,0) + DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,0,0) /* This flavor may reset the last error before the call (if ret=0 may be OK) */ #define DeclWinFuncByORD_CACHE_resetError_survive(ret,name,o,at,args) \ - DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,1,0) + DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,1,0) #define DeclWinFuncByORD_CACHE_r(ret,name,o,at,args,r,die) \ static ret (*CAT2(p__Win,name)) at; \ static ret name at { \ - if (!CAT2(p__Win,name)) \ - AssignFuncPByORD(CAT2(p__Win,name), o); \ - if (r) ResetWinError(); \ - return SaveCroakWinError(CAT2(p__Win,name) args, die, "[Win]", STRINGIFY(name)); } + if (!CAT2(p__Win,name)) \ + AssignFuncPByORD(CAT2(p__Win,name), o); \ + if (r) ResetWinError(); \ + return SaveCroakWinError(CAT2(p__Win,name) args, die, "[Win]", STRINGIFY(name)); } /* These flavors additionally assume ORD is name with prepended ORD_Win */ #define DeclWinFunc_CACHE(ret,name,at,args) \ - DeclWinFuncByORD_CACHE(ret,name,CAT2(ORD_Win,name),at,args) + DeclWinFuncByORD_CACHE(ret,name,CAT2(ORD_Win,name),at,args) #define DeclWinFunc_CACHE_resetError(ret,name,at,args) \ - DeclWinFuncByORD_CACHE_resetError(ret,name,CAT2(ORD_Win,name),at,args) + DeclWinFuncByORD_CACHE_resetError(ret,name,CAT2(ORD_Win,name),at,args) #define DeclWinFunc_CACHE_survive(ret,name,at,args) \ - DeclWinFuncByORD_CACHE_survive(ret,name,CAT2(ORD_Win,name),at,args) + DeclWinFuncByORD_CACHE_survive(ret,name,CAT2(ORD_Win,name),at,args) #define DeclWinFunc_CACHE_resetError_survive(ret,name,at,args) \ - DeclWinFuncByORD_CACHE_resetError_survive(ret,name,CAT2(ORD_Win,name),at,args) + DeclWinFuncByORD_CACHE_resetError_survive(ret,name,CAT2(ORD_Win,name),at,args) void ResetWinError(void); void CroakWinError(int die, char *name); @@ -815,12 +815,12 @@ void croak_with_os2error(char *s) __attribute__((noreturn)); /* propagates rc */ #define os2win_croak(rc,msg) \ - SaveCroakWinError((expr), 1 /* die */, /* no prefix */, (msg)) + SaveCroakWinError((expr), 1 /* die */, /* no prefix */, (msg)) /* propagates rc; use with functions which may return 0 on success */ #define os2win_croak_0OK(rc,msg) \ - SaveCroakWinError((ResetWinError, (expr)), \ - 1 /* die */, /* no prefix */, (msg)) + SaveCroakWinError((ResetWinError, (expr)), \ + 1 /* die */, /* no prefix */, (msg)) #ifdef PERL_CORE int os2_do_spawn(pTHX_ char *cmd); @@ -840,7 +840,7 @@ int os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp); # define LOG_DEBUG 7 /* debug-level messages */ # define LOG_PRIMASK 0x007 /* mask to extract priority part (internal) */ - /* extract priority */ + /* extract priority */ # define LOG_PRI(p) ((p) & LOG_PRIMASK) # define LOG_MAKEPRI(fac, pri) (((fac) << 3) | (pri)) @@ -855,7 +855,7 @@ int os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp); # define LOG_NEWS (7<<3) /* network news subsystem */ # define LOG_UUCP (8<<3) /* UUCP subsystem */ # define LOG_CRON (15<<3) /* clock daemon */ - /* other codes through 15 reserved for system use */ + /* other codes through 15 reserved for system use */ # define LOG_LOCAL0 (16<<3) /* reserved for local use */ # define LOG_LOCAL1 (17<<3) /* reserved for local use */ # define LOG_LOCAL2 (18<<3) /* reserved for local use */ @@ -867,7 +867,7 @@ int os2_do_aspawn(pTHX_ SV *really, SV **vmark, SV **vsp); # define LOG_NFACILITIES 24 /* current number of facilities */ # define LOG_FACMASK 0x03f8 /* mask to extract facility part */ - /* facility of pri */ + /* facility of pri */ # define LOG_FAC(p) (((p) & LOG_FACMASK) >> 3) /* @@ -1080,7 +1080,7 @@ unsigned long LIS_pPIB; /* Pointer to PIB */ /* ************************************************************ */ #define Dos32QuerySysState DosQuerySysState #define QuerySysState(flags, pid, buf, bufsz) \ - Dos32QuerySysState(flags, 0, pid, 0, buf, bufsz) + Dos32QuerySysState(flags, 0, pid, 0, buf, bufsz) #define QSS_PROCESS 1 #define QSS_MODULE 4 @@ -1091,156 +1091,156 @@ unsigned long LIS_pPIB; /* Pointer to PIB */ #ifdef _OS2_H APIRET APIENTRY Dos32QuerySysState(ULONG func,ULONG arg1,ULONG pid, - ULONG _res_,PVOID buf,ULONG bufsz); + ULONG _res_,PVOID buf,ULONG bufsz); typedef struct { - ULONG threadcnt; - ULONG proccnt; - ULONG modulecnt; + ULONG threadcnt; + ULONG proccnt; + ULONG modulecnt; } QGLOBAL, *PQGLOBAL; typedef struct { - ULONG rectype; - USHORT threadid; - USHORT slotid; - ULONG sleepid; - ULONG priority; - ULONG systime; - ULONG usertime; - UCHAR state; - UCHAR _reserved1_; /* padding to ULONG */ - USHORT _reserved2_; /* padding to ULONG */ + ULONG rectype; + USHORT threadid; + USHORT slotid; + ULONG sleepid; + ULONG priority; + ULONG systime; + ULONG usertime; + UCHAR state; + UCHAR _reserved1_; /* padding to ULONG */ + USHORT _reserved2_; /* padding to ULONG */ } QTHREAD, *PQTHREAD; typedef struct { - USHORT sfn; - USHORT refcnt; - USHORT flags1; - USHORT flags2; - USHORT accmode1; - USHORT accmode2; - ULONG filesize; - USHORT volhnd; - USHORT attrib; - USHORT _reserved_; + USHORT sfn; + USHORT refcnt; + USHORT flags1; + USHORT flags2; + USHORT accmode1; + USHORT accmode2; + ULONG filesize; + USHORT volhnd; + USHORT attrib; + USHORT _reserved_; } QFDS, *PQFDS; typedef struct qfile { - ULONG rectype; - struct qfile *next; - ULONG opencnt; - PQFDS filedata; - char name[1]; + ULONG rectype; + struct qfile *next; + ULONG opencnt; + PQFDS filedata; + char name[1]; } QFILE, *PQFILE; typedef struct { - ULONG rectype; - PQTHREAD threads; - USHORT pid; - USHORT ppid; - ULONG type; - ULONG state; - ULONG sessid; - USHORT hndmod; - USHORT threadcnt; - ULONG privsem32cnt; - ULONG _reserved2_; - USHORT sem16cnt; - USHORT dllcnt; - USHORT shrmemcnt; - USHORT fdscnt; - PUSHORT sem16s; - PUSHORT dlls; - PUSHORT shrmems; - PUSHORT fds; + ULONG rectype; + PQTHREAD threads; + USHORT pid; + USHORT ppid; + ULONG type; + ULONG state; + ULONG sessid; + USHORT hndmod; + USHORT threadcnt; + ULONG privsem32cnt; + ULONG _reserved2_; + USHORT sem16cnt; + USHORT dllcnt; + USHORT shrmemcnt; + USHORT fdscnt; + PUSHORT sem16s; + PUSHORT dlls; + PUSHORT shrmems; + PUSHORT fds; } QPROCESS, *PQPROCESS; typedef struct sema { - struct sema *next; - USHORT refcnt; - UCHAR sysflags; - UCHAR sysproccnt; - ULONG _reserved1_; - USHORT index; - CHAR name[1]; + struct sema *next; + USHORT refcnt; + UCHAR sysflags; + UCHAR sysproccnt; + ULONG _reserved1_; + USHORT index; + CHAR name[1]; } QSEMA, *PQSEMA; typedef struct { - ULONG rectype; - ULONG _reserved1_; - USHORT _reserved2_; - USHORT syssemidx; - ULONG index; - QSEMA sema; + ULONG rectype; + ULONG _reserved1_; + USHORT _reserved2_; + USHORT syssemidx; + ULONG index; + QSEMA sema; } QSEMSTRUC, *PQSEMSTRUC; typedef struct { - USHORT pid; - USHORT opencnt; + USHORT pid; + USHORT opencnt; } QSEMOWNER32, *PQSEMOWNER32; typedef struct { - PQSEMOWNER32 own; - PCHAR name; - PVOID semrecs; /* array of associated sema's */ - USHORT flags; - USHORT semreccnt; - USHORT waitcnt; - USHORT _reserved_; /* padding to ULONG */ + PQSEMOWNER32 own; + PCHAR name; + PVOID semrecs; /* array of associated sema's */ + USHORT flags; + USHORT semreccnt; + USHORT waitcnt; + USHORT _reserved_; /* padding to ULONG */ } QSEMSMUX32, *PQSEMSMUX32; typedef struct { - PQSEMOWNER32 own; - PCHAR name; - PQSEMSMUX32 mux; - USHORT flags; - USHORT postcnt; + PQSEMOWNER32 own; + PCHAR name; + PQSEMSMUX32 mux; + USHORT flags; + USHORT postcnt; } QSEMEV32, *PQSEMEV32; typedef struct { - PQSEMOWNER32 own; - PCHAR name; - PQSEMSMUX32 mux; - USHORT flags; - USHORT refcnt; - USHORT thrdnum; - USHORT _reserved_; /* padding to ULONG */ + PQSEMOWNER32 own; + PCHAR name; + PQSEMSMUX32 mux; + USHORT flags; + USHORT refcnt; + USHORT thrdnum; + USHORT _reserved_; /* padding to ULONG */ } QSEMMUX32, *PQSEMMUX32; typedef struct semstr32 { - struct semstr *next; - QSEMEV32 evsem; - QSEMMUX32 muxsem; - QSEMSMUX32 smuxsem; + struct semstr *next; + QSEMEV32 evsem; + QSEMMUX32 muxsem; + QSEMSMUX32 smuxsem; } QSEMSTRUC32, *PQSEMSTRUC32; typedef struct shrmem { - struct shrmem *next; - USHORT hndshr; - USHORT selshr; - USHORT refcnt; - CHAR name[1]; + struct shrmem *next; + USHORT hndshr; + USHORT selshr; + USHORT refcnt; + CHAR name[1]; } QSHRMEM, *PQSHRMEM; typedef struct module { - struct module *next; - USHORT hndmod; - USHORT type; - ULONG refcnt; - ULONG segcnt; - PVOID _reserved_; - PCHAR name; - USHORT modref[1]; + struct module *next; + USHORT hndmod; + USHORT type; + ULONG refcnt; + ULONG segcnt; + PVOID _reserved_; + PCHAR name; + USHORT modref[1]; } QMODULE, *PQMODULE; typedef struct { - PQGLOBAL gbldata; - PQPROCESS procdata; - PQSEMSTRUC semadata; - PQSEMSTRUC32 sem32data; - PQSHRMEM shrmemdata; - PQMODULE moddata; - PVOID _reserved2_; - PQFILE filedata; + PQGLOBAL gbldata; + PQPROCESS procdata; + PQSEMSTRUC semadata; + PQSEMSTRUC32 sem32data; + PQSHRMEM shrmemdata; + PQMODULE moddata; + PVOID _reserved2_; + PQFILE filedata; } QTOPLEVEL, *PQTOPLEVEL; /* ************************************************************ */ diff --git a/os2/perlrexx.c b/os2/perlrexx.c index 18d655137d..8d3237e887 100644 --- a/os2/perlrexx.c +++ b/os2/perlrexx.c @@ -64,17 +64,17 @@ init_perl(int doparse) char *argv[3] = {"perl_in_REXX", "-e", ""}; if (!perlos2_is_inited) { - perlos2_is_inited = 1; - init_perlos2(); + perlos2_is_inited = 1; + init_perlos2(); } if (my_perl) - return 1; + return 1; if (!PL_do_undump) { - my_perl = perl_alloc(); - if (!my_perl) - return 0; - perl_construct(my_perl); - PL_perl_destruct_level = 1; + my_perl = perl_alloc(); + if (!my_perl) + return 0; + perl_construct(my_perl); + PL_perl_destruct_level = 1; } if (!doparse) return 1; @@ -86,19 +86,19 @@ static char last_error[4096]; static int seterr(char *format, ...) { - va_list va; - char *s = last_error; - - va_start(va, format); - if (s[0]) { - s += strlen(s); - if (s[-1] != '\n') { - snprintf(s, sizeof(last_error) - (s - last_error), "\n"); - s += strlen(s); - } - } - vsnprintf(s, sizeof(last_error) - (s - last_error), format, va); - return 1; + va_list va; + char *s = last_error; + + va_start(va, format); + if (s[0]) { + s += strlen(s); + if (s[-1] != '\n') { + snprintf(s, sizeof(last_error) - (s - last_error), "\n"); + s += strlen(s); + } + } + vsnprintf(s, sizeof(last_error) - (s - last_error), format, va); + return 1; } /* The REXX-callable entrypoints ... */ @@ -112,30 +112,30 @@ ULONG PERL (PCSZ name, LONG rargc, const RXSTRING *rargv, ULONG ret; if (rargc != 1) - return seterr("one argument expected, got %ld", rargc); + return seterr("one argument expected, got %ld", rargc); if (rargv[0].strlength >= sizeof(buf)) - return seterr("length of the argument %ld exceeds the maximum %ld", - rargv[0].strlength, (long)sizeof(buf) - 1); + return seterr("length of the argument %ld exceeds the maximum %ld", + rargv[0].strlength, (long)sizeof(buf) - 1); if (!init_perl(0)) - return 1; + return 1; memcpy(buf, rargv[0].strptr, rargv[0].strlength); buf[rargv[0].strlength] = 0; if (!perl_parse(my_perl, xs_init, 3, argv, (char **)NULL)) - perl_run(my_perl); + perl_run(my_perl); exitstatus = perl_destruct(my_perl); perl_free(my_perl); my_perl = 0; if (exitstatus) - ret = 1; + ret = 1; else { - ret = 0; - sprintf(retstr->strptr, "%s", "ok"); - retstr->strlength = strlen (retstr->strptr); + ret = 0; + sprintf(retstr->strptr, "%s", "ok"); + retstr->strlength = strlen (retstr->strptr); } PERL_SYS_TERM1(0); return ret; @@ -145,7 +145,7 @@ ULONG PERLEXIT (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) { if (rargc != 0) - return seterr("no arguments expected, got %ld", rargc); + return seterr("no arguments expected, got %ld", rargc); PERL_SYS_TERM1(0); return 0; } @@ -154,9 +154,9 @@ ULONG PERLTERM (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) { if (rargc != 0) - return seterr("no arguments expected, got %ld", rargc); + return seterr("no arguments expected, got %ld", rargc); if (!my_perl) - return seterr("no perl interpreter present"); + return seterr("no perl interpreter present"); perl_destruct(my_perl); perl_free(my_perl); my_perl = 0; @@ -171,9 +171,9 @@ ULONG PERLINIT (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRING retstr) { if (rargc != 0) - return seterr("no argument expected, got %ld", rargc); + return seterr("no argument expected, got %ld", rargc); if (!init_perl(1)) - return 1; + return 1; sprintf(retstr->strptr, "%s", "ok"); retstr->strlength = strlen (retstr->strptr); @@ -186,13 +186,13 @@ PERLLASTERROR (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRX int len = strlen(last_error); if (len <= 256 /* Default buffer is 256-char long */ - || !DosAllocMem((PPVOID)&retstr->strptr, len, - PAG_READ|PAG_WRITE|PAG_COMMIT)) { - memcpy(retstr->strptr, last_error, len); - retstr->strlength = len; + || !DosAllocMem((PPVOID)&retstr->strptr, len, + PAG_READ|PAG_WRITE|PAG_COMMIT)) { + memcpy(retstr->strptr, last_error, len); + retstr->strlength = len; } else { - strcpy(retstr->strptr, "[Not enough memory to copy the errortext]"); - retstr->strlength = strlen(retstr->strptr); + strcpy(retstr->strptr, "[Not enough memory to copy the errortext]"); + retstr->strlength = strlen(retstr->strptr); } return 0; } @@ -206,10 +206,10 @@ PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRIN last_error[0] = 0; if (rargc != 1) - return seterr("one argument expected, got %ld", rargc); + return seterr("one argument expected, got %ld", rargc); if (!init_perl(1)) - return seterr("error initializing perl"); + return seterr("error initializing perl"); { dSP; @@ -227,17 +227,17 @@ PERLEVAL (PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTRIN ret = 0; if (SvTRUE(ERRSV)) - ret = seterr(SvPV(ERRSV, n_a)); + ret = seterr(SvPV(ERRSV, n_a)); if (!SvOK(res)) - ret = seterr("undefined value returned by Perl-in-REXX"); + ret = seterr("undefined value returned by Perl-in-REXX"); str = SvPV(res, len); if (len <= 256 /* Default buffer is 256-char long */ - || !DosAllocMem((PPVOID)&retstr->strptr, len, - PAG_READ|PAG_WRITE|PAG_COMMIT)) { - memcpy(retstr->strptr, str, len); - retstr->strlength = len; + || !DosAllocMem((PPVOID)&retstr->strptr, len, + PAG_READ|PAG_WRITE|PAG_COMMIT)) { + memcpy(retstr->strptr, str, len); + retstr->strlength = len; } else - ret = seterr("Not enough memory for the return string of Perl-in-REXX"); + ret = seterr("Not enough memory for the return string of Perl-in-REXX"); FREETMPS; LEAVE; @@ -255,7 +255,7 @@ PERLEVALSUBCOMMAND( ULONG rc = PERLEVAL(NULL, 1, command, NULL, retstr); if (rc) - *flags = RXSUBCOM_ERROR; /* raise error condition */ + *flags = RXSUBCOM_ERROR; /* raise error condition */ return 0; /* finished */ } @@ -284,7 +284,7 @@ PERLEXPORTALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXS int i = -1; while (++i < ArrLength(funcs) - 1) - RexxRegisterFunctionExe(funcs[i].name, funcs[i].f); + RexxRegisterFunctionExe(funcs[i].name, funcs[i].f); RexxRegisterSubcomExe("EVALPERL", (PFN)&PERLEVALSUBCOMMAND, NULL); retstr->strlength = 0; return 0; @@ -296,7 +296,7 @@ PERLDROPALL(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PRXSTR int i = -1; while (++i < ArrLength(funcs)) - RexxDeregisterFunction(funcs[i].name); + RexxDeregisterFunction(funcs[i].name); RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */); retstr->strlength = 0; return 0; @@ -308,7 +308,7 @@ PERLDROPALLEXIT(PCSZ name, LONG rargc, const RXSTRING *rargv, PCSZ queuename, PR int i = -1; while (++i < ArrLength(funcs)) - RexxDeregisterFunction(funcs[i].name); + RexxDeregisterFunction(funcs[i].name); RexxDeregisterSubcom("EVALPERL", NULL /* Not a DLL version */); PERL_SYS_TERM1(0); retstr->strlength = 0; @@ -201,19 +201,19 @@ Perl_pad_new(pTHX_ int flags) /* save existing state, ... */ if (flags & padnew_SAVE) { - SAVECOMPPAD(); - if (! (flags & padnew_CLONE)) { - SAVESPTR(PL_comppad_name); + SAVECOMPPAD(); + if (! (flags & padnew_CLONE)) { + SAVESPTR(PL_comppad_name); save_strlen((STRLEN *)&PL_padix); save_strlen((STRLEN *)&PL_constpadix); - save_strlen((STRLEN *)&PL_comppad_name_fill); - save_strlen((STRLEN *)&PL_min_intro_pending); - save_strlen((STRLEN *)&PL_max_intro_pending); - SAVEBOOL(PL_cv_has_eval); - if (flags & padnew_SAVESUB) { - SAVEBOOL(PL_pad_reset_pending); - } - } + save_strlen((STRLEN *)&PL_comppad_name_fill); + save_strlen((STRLEN *)&PL_min_intro_pending); + save_strlen((STRLEN *)&PL_max_intro_pending); + SAVEBOOL(PL_cv_has_eval); + if (flags & padnew_SAVESUB) { + SAVEBOOL(PL_pad_reset_pending); + } + } } /* ... create new pad ... */ @@ -223,16 +223,16 @@ Perl_pad_new(pTHX_ int flags) if (flags & padnew_CLONE) { AV * const a0 = newAV(); /* will be @_ */ - av_store(pad, 0, MUTABLE_SV(a0)); - AvREIFY_only(a0); + av_store(pad, 0, MUTABLE_SV(a0)); + AvREIFY_only(a0); - PadnamelistREFCNT(padname = PL_comppad_name)++; + PadnamelistREFCNT(padname = PL_comppad_name)++; } else { - padlist->xpadl_id = PL_padlist_generation++; - av_store(pad, 0, NULL); - padname = newPADNAMELIST(0); - padnamelist_store(padname, 0, &PL_padname_undef); + padlist->xpadl_id = PL_padlist_generation++; + av_store(pad, 0, NULL); + padname = newPADNAMELIST(0); + padnamelist_store(padname, 0, &PL_padname_undef); } /* Most subroutines never recurse, hence only need 2 entries in the padlist @@ -251,20 +251,20 @@ Perl_pad_new(pTHX_ int flags) PL_curpad = AvARRAY(pad); if (! (flags & padnew_CLONE)) { - PL_comppad_name = padname; - PL_comppad_name_fill = 0; - PL_min_intro_pending = 0; - PL_padix = 0; - PL_constpadix = 0; - PL_cv_has_eval = 0; + PL_comppad_name = padname; + PL_comppad_name_fill = 0; + PL_min_intro_pending = 0; + PL_padix = 0; + PL_constpadix = 0; + PL_cv_has_eval = 0; } DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] new: compcv=0x%" UVxf - " name=0x%" UVxf " flags=0x%" UVxf "\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv), - PTR2UV(padname), (UV)flags - ) + "Pad 0x%" UVxf "[0x%" UVxf "] new: compcv=0x%" UVxf + " name=0x%" UVxf " flags=0x%" UVxf "\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), PTR2UV(PL_compcv), + PTR2UV(padname), (UV)flags + ) ); return (PADLIST*)padlist; @@ -302,15 +302,15 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) PERL_ARGS_ASSERT_CV_UNDEF_FLAGS; DEBUG_X(PerlIO_printf(Perl_debug_log, - "CV undef: cv=0x%" UVxf " comppad=0x%" UVxf "\n", - PTR2UV(cv), PTR2UV(PL_comppad)) + "CV undef: cv=0x%" UVxf " comppad=0x%" UVxf "\n", + PTR2UV(cv), PTR2UV(PL_comppad)) ); if (CvFILE(&cvbody)) { - char * file = CvFILE(&cvbody); - CvFILE(&cvbody) = NULL; - if(CvDYNFILE(&cvbody)) - Safefree(file); + char * file = CvFILE(&cvbody); + CvFILE(&cvbody) = NULL; + if(CvDYNFILE(&cvbody)) + Safefree(file); } /* CvSLABBED_off(&cvbody); *//* turned off below */ @@ -332,7 +332,7 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) CvSTART(&cvbody) = NULL; LEAVE; } - else if (CvSLABBED(&cvbody)) { + else if (CvSLABBED(&cvbody)) { if( CvSTART(&cvbody)) { ENTER; PAD_SAVE_SETNULLPAD(); @@ -351,128 +351,128 @@ Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) } } else { /* dont bother checking if CvXSUB(cv) is true, less branching */ - CvXSUB(&cvbody) = NULL; + CvXSUB(&cvbody) = NULL; } SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */ sv_unmagic((SV *)cv, PERL_MAGIC_checkcall); if (!(flags & CV_UNDEF_KEEP_NAME)) { - if (CvNAMED(&cvbody)) { - CvNAME_HEK_set(&cvbody, NULL); - CvNAMED_off(&cvbody); - } - else CvGV_set(cv, NULL); + if (CvNAMED(&cvbody)) { + CvNAME_HEK_set(&cvbody, NULL); + CvNAMED_off(&cvbody); + } + else CvGV_set(cv, NULL); } /* This statement and the subsequence if block was pad_undef(). */ pad_peg("pad_undef"); if (!CvISXSUB(&cvbody) && CvPADLIST(&cvbody)) { - PADOFFSET ix; - const PADLIST *padlist = CvPADLIST(&cvbody); - - /* Free the padlist associated with a CV. - If parts of it happen to be current, we null the relevant PL_*pad* - global vars so that we don't have any dangling references left. - We also repoint the CvOUTSIDE of any about-to-be-orphaned inner - subs to the outer of this cv. */ - - DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad undef: cv=0x%" UVxf " padlist=0x%" UVxf " comppad=0x%" UVxf "\n", - PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad)) - ); - - /* detach any '&' anon children in the pad; if afterwards they - * are still live, fix up their CvOUTSIDEs to point to our outside, - * bypassing us. */ - - if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */ - CV * const outercv = CvOUTSIDE(&cvbody); - const U32 seq = CvOUTSIDE_SEQ(&cvbody); - PADNAMELIST * const comppad_name = PadlistNAMES(padlist); - PADNAME ** const namepad = PadnamelistARRAY(comppad_name); - PAD * const comppad = PadlistARRAY(padlist)[1]; - SV ** const curpad = AvARRAY(comppad); - for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) { - PADNAME * const name = namepad[ix]; - if (name && PadnamePV(name) && *PadnamePV(name) == '&') - { - CV * const innercv = MUTABLE_CV(curpad[ix]); - U32 inner_rc; - assert(innercv); - assert(SvTYPE(innercv) != SVt_PVFM); - inner_rc = SvREFCNT(innercv); - assert(inner_rc); - - if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */ - curpad[ix] = NULL; - SvREFCNT_dec_NN(innercv); - inner_rc--; - } - - /* in use, not just a prototype */ - if (inner_rc && SvTYPE(innercv) == SVt_PVCV - && (CvOUTSIDE(innercv) == cv)) - { - assert(CvWEAKOUTSIDE(innercv)); - /* don't relink to grandfather if he's being freed */ - if (outercv && SvREFCNT(outercv)) { - CvWEAKOUTSIDE_off(innercv); - CvOUTSIDE(innercv) = outercv; - CvOUTSIDE_SEQ(innercv) = seq; - SvREFCNT_inc_simple_void_NN(outercv); - } - else { - CvOUTSIDE(innercv) = NULL; - } - } - } - } - } - - ix = PadlistMAX(padlist); - while (ix > 0) { - PAD * const sv = PadlistARRAY(padlist)[ix--]; - if (sv) { - if (sv == PL_comppad) { - PL_comppad = NULL; - PL_curpad = NULL; - } - SvREFCNT_dec_NN(sv); - } - } - { - PADNAMELIST * const names = PadlistNAMES(padlist); - if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1) - PL_comppad_name = NULL; - PadnamelistREFCNT_dec(names); - } - if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist)); - Safefree(padlist); - CvPADLIST_set(&cvbody, NULL); + PADOFFSET ix; + const PADLIST *padlist = CvPADLIST(&cvbody); + + /* Free the padlist associated with a CV. + If parts of it happen to be current, we null the relevant PL_*pad* + global vars so that we don't have any dangling references left. + We also repoint the CvOUTSIDE of any about-to-be-orphaned inner + subs to the outer of this cv. */ + + DEBUG_X(PerlIO_printf(Perl_debug_log, + "Pad undef: cv=0x%" UVxf " padlist=0x%" UVxf " comppad=0x%" UVxf "\n", + PTR2UV(cv), PTR2UV(padlist), PTR2UV(PL_comppad)) + ); + + /* detach any '&' anon children in the pad; if afterwards they + * are still live, fix up their CvOUTSIDEs to point to our outside, + * bypassing us. */ + + if (PL_phase != PERL_PHASE_DESTRUCT) { /* don't bother during global destruction */ + CV * const outercv = CvOUTSIDE(&cvbody); + const U32 seq = CvOUTSIDE_SEQ(&cvbody); + PADNAMELIST * const comppad_name = PadlistNAMES(padlist); + PADNAME ** const namepad = PadnamelistARRAY(comppad_name); + PAD * const comppad = PadlistARRAY(padlist)[1]; + SV ** const curpad = AvARRAY(comppad); + for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) { + PADNAME * const name = namepad[ix]; + if (name && PadnamePV(name) && *PadnamePV(name) == '&') + { + CV * const innercv = MUTABLE_CV(curpad[ix]); + U32 inner_rc; + assert(innercv); + assert(SvTYPE(innercv) != SVt_PVFM); + inner_rc = SvREFCNT(innercv); + assert(inner_rc); + + if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/ */ + curpad[ix] = NULL; + SvREFCNT_dec_NN(innercv); + inner_rc--; + } + + /* in use, not just a prototype */ + if (inner_rc && SvTYPE(innercv) == SVt_PVCV + && (CvOUTSIDE(innercv) == cv)) + { + assert(CvWEAKOUTSIDE(innercv)); + /* don't relink to grandfather if he's being freed */ + if (outercv && SvREFCNT(outercv)) { + CvWEAKOUTSIDE_off(innercv); + CvOUTSIDE(innercv) = outercv; + CvOUTSIDE_SEQ(innercv) = seq; + SvREFCNT_inc_simple_void_NN(outercv); + } + else { + CvOUTSIDE(innercv) = NULL; + } + } + } + } + } + + ix = PadlistMAX(padlist); + while (ix > 0) { + PAD * const sv = PadlistARRAY(padlist)[ix--]; + if (sv) { + if (sv == PL_comppad) { + PL_comppad = NULL; + PL_curpad = NULL; + } + SvREFCNT_dec_NN(sv); + } + } + { + PADNAMELIST * const names = PadlistNAMES(padlist); + if (names == PL_comppad_name && PadnamelistREFCNT(names) == 1) + PL_comppad_name = NULL; + PadnamelistREFCNT_dec(names); + } + if (PadlistARRAY(padlist)) Safefree(PadlistARRAY(padlist)); + Safefree(padlist); + CvPADLIST_set(&cvbody, NULL); } else if (CvISXSUB(&cvbody)) - CvHSCXT(&cvbody) = NULL; + CvHSCXT(&cvbody) = NULL; /* else is (!CvISXSUB(&cvbody) && !CvPADLIST(&cvbody)) {do nothing;} */ /* remove CvOUTSIDE unless this is an undef rather than a free */ if (!SvREFCNT(cv)) { - CV * outside = CvOUTSIDE(&cvbody); - if(outside) { - CvOUTSIDE(&cvbody) = NULL; - if (!CvWEAKOUTSIDE(&cvbody)) - SvREFCNT_dec_NN(outside); - } + CV * outside = CvOUTSIDE(&cvbody); + if(outside) { + CvOUTSIDE(&cvbody) = NULL; + if (!CvWEAKOUTSIDE(&cvbody)) + SvREFCNT_dec_NN(outside); + } } if (CvCONST(&cvbody)) { - SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr)); - /* CvCONST_off(cv); *//* turned off below */ + SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(&cvbody).any_ptr)); + /* CvCONST_off(cv); *//* turned off below */ } /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and * LEXICAL, which are used to determine the sub's name. */ CvFLAGS(&cvbody) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL - |CVf_NAMED); + |CVf_NAMED); } /* @@ -508,11 +508,11 @@ Perl_cv_forget_slab(pTHX_ CV *cv) if (slab) { #ifdef PERL_DEBUG_READONLY_OPS - const size_t refcnt = slab->opslab_refcnt; + const size_t refcnt = slab->opslab_refcnt; #endif - OpslabREFCNT_dec(slab); + OpslabREFCNT_dec(slab); #ifdef PERL_DEBUG_READONLY_OPS - if (refcnt > 1) Slab_to_ro(slab); + if (refcnt > 1) Slab_to_ro(slab); #endif } } @@ -534,7 +534,7 @@ is done. Returns the offset of the allocated pad slot. static PADOFFSET S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash, - HV *ourstash) + HV *ourstash) { const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); @@ -543,22 +543,22 @@ S_pad_alloc_name(pTHX_ PADNAME *name, U32 flags, HV *typestash, ASSERT_CURPAD_ACTIVE("pad_alloc_name"); if (typestash) { - SvPAD_TYPED_on(name); - PadnameTYPE(name) = - MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))); + SvPAD_TYPED_on(name); + PadnameTYPE(name) = + MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash))); } if (ourstash) { - SvPAD_OUR_on(name); - SvOURSTASH_set(name, ourstash); - SvREFCNT_inc_simple_void_NN(ourstash); + SvPAD_OUR_on(name); + SvOURSTASH_set(name, ourstash); + SvREFCNT_inc_simple_void_NN(ourstash); } else if (flags & padadd_STATE) { - SvPAD_STATE_on(name); + SvPAD_STATE_on(name); } padnamelist_store(PL_comppad_name, offset, name); if (PadnameLEN(name) > 1) - PadnamelistMAXNAMED(PL_comppad_name) = offset; + PadnamelistMAXNAMED(PL_comppad_name) = offset; return offset; } @@ -585,7 +585,7 @@ flags can be OR'ed together: PADOFFSET Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, - U32 flags, HV *typestash, HV *ourstash) + U32 flags, HV *typestash, HV *ourstash) { PADOFFSET offset; PADNAME *name; @@ -593,18 +593,18 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, PERL_ARGS_ASSERT_PAD_ADD_NAME_PVN; if (flags & ~(padadd_OUR|padadd_STATE|padadd_NO_DUP_CHECK)) - Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: pad_add_name_pvn illegal flag bits 0x%" UVxf, + (UV)flags); name = newPADNAMEpvn(namepv, namelen); if ((flags & padadd_NO_DUP_CHECK) == 0) { - ENTER; - SAVEFREEPADNAME(name); /* in case of fatal warnings */ - /* check for duplicate declaration */ - pad_check_dup(name, flags & padadd_OUR, ourstash); - PadnameREFCNT(name)++; - LEAVE; + ENTER; + SAVEFREEPADNAME(name); /* in case of fatal warnings */ + /* check for duplicate declaration */ + pad_check_dup(name, flags & padadd_OUR, ourstash); + PadnameREFCNT(name)++; + LEAVE; } offset = pad_alloc_name(name, flags, typestash, ourstash); @@ -614,22 +614,22 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, COP_SEQ_RANGE_HIGH_set(name, 0); if (!PL_min_intro_pending) - PL_min_intro_pending = offset; + PL_min_intro_pending = offset; PL_max_intro_pending = offset; /* if it's not a simple scalar, replace with an AV or HV */ assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); assert(SvREFCNT(PL_curpad[offset]) == 1); if (namelen != 0 && *namepv == '@') - sv_upgrade(PL_curpad[offset], SVt_PVAV); + sv_upgrade(PL_curpad[offset], SVt_PVAV); else if (namelen != 0 && *namepv == '%') - sv_upgrade(PL_curpad[offset], SVt_PVHV); + sv_upgrade(PL_curpad[offset], SVt_PVHV); else if (namelen != 0 && *namepv == '&') - sv_upgrade(PL_curpad[offset], SVt_PVCV); + sv_upgrade(PL_curpad[offset], SVt_PVCV); assert(SvPADMY(PL_curpad[offset])); DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n", - (long)offset, PadnamePV(name), - PTR2UV(PL_curpad[offset]))); + "Pad addname: %ld \"%s\" new lex=0x%" UVxf "\n", + (long)offset, PadnamePV(name), + PTR2UV(PL_curpad[offset]))); return offset; } @@ -645,7 +645,7 @@ instead of a string/length pair. PADOFFSET Perl_pad_add_name_pv(pTHX_ const char *name, - const U32 flags, HV *typestash, HV *ourstash) + const U32 flags, HV *typestash, HV *ourstash) { PERL_ARGS_ASSERT_PAD_ADD_NAME_PV; return pad_add_name_pvn(name, strlen(name), flags, typestash, ourstash); @@ -706,63 +706,63 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) ASSERT_CURPAD_ACTIVE("pad_alloc"); if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p", - AvARRAY(PL_comppad), PL_curpad); + Perl_croak(aTHX_ "panic: pad_alloc, %p!=%p", + AvARRAY(PL_comppad), PL_curpad); if (PL_pad_reset_pending) - pad_reset(); + pad_reset(); if (tmptype == SVs_PADMY) { /* Not & because this ‘flag’ is 0. */ - /* For a my, simply push a null SV onto the end of PL_comppad. */ - sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); - retval = (PADOFFSET)AvFILLp(PL_comppad); + /* For a my, simply push a null SV onto the end of PL_comppad. */ + sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); + retval = (PADOFFSET)AvFILLp(PL_comppad); } else { - /* For a tmp, scan the pad from PL_padix upwards - * for a slot which has no name and no active value. - * For a constant, likewise, but use PL_constpadix. - */ - PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name); - const SSize_t names_fill = PadnamelistMAX(PL_comppad_name); - const bool konst = cBOOL(tmptype & SVf_READONLY); - retval = konst ? PL_constpadix : PL_padix; - for (;;) { - /* - * Entries that close over unavailable variables - * in outer subs contain values not marked PADMY. - * Thus we must skip, not just pad values that are - * marked as current pad values, but also those with names. - * If pad_reset is enabled, ‘current’ means different - * things depending on whether we are allocating a con- - * stant or a target. For a target, things marked PADTMP - * can be reused; not so for constants. - */ - PADNAME *pn; - if (++retval <= names_fill && - (pn = names[retval]) && PadnamePV(pn)) - continue; - sv = *av_fetch(PL_comppad, retval, TRUE); - if (!(SvFLAGS(sv) & + /* For a tmp, scan the pad from PL_padix upwards + * for a slot which has no name and no active value. + * For a constant, likewise, but use PL_constpadix. + */ + PADNAME * const * const names = PadnamelistARRAY(PL_comppad_name); + const SSize_t names_fill = PadnamelistMAX(PL_comppad_name); + const bool konst = cBOOL(tmptype & SVf_READONLY); + retval = konst ? PL_constpadix : PL_padix; + for (;;) { + /* + * Entries that close over unavailable variables + * in outer subs contain values not marked PADMY. + * Thus we must skip, not just pad values that are + * marked as current pad values, but also those with names. + * If pad_reset is enabled, ‘current’ means different + * things depending on whether we are allocating a con- + * stant or a target. For a target, things marked PADTMP + * can be reused; not so for constants. + */ + PADNAME *pn; + if (++retval <= names_fill && + (pn = names[retval]) && PadnamePV(pn)) + continue; + sv = *av_fetch(PL_comppad, retval, TRUE); + if (!(SvFLAGS(sv) & #ifdef USE_PAD_RESET - (konst ? SVs_PADTMP : 0) + (konst ? SVs_PADTMP : 0) #else - SVs_PADTMP + SVs_PADTMP #endif - )) - break; - } - if (konst) { - padnamelist_store(PL_comppad_name, retval, &PL_padname_const); - tmptype &= ~SVf_READONLY; - tmptype |= SVs_PADTMP; - } - *(konst ? &PL_constpadix : &PL_padix) = retval; + )) + break; + } + if (konst) { + padnamelist_store(PL_comppad_name, retval, &PL_padname_const); + tmptype &= ~SVf_READONLY; + tmptype |= SVs_PADTMP; + } + *(konst ? &PL_constpadix : &PL_padix) = retval; } SvFLAGS(sv) |= tmptype; PL_curpad = AvARRAY(PL_comppad); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval, - PL_op_name[optype])); + "Pad 0x%" UVxf "[0x%" UVxf "] alloc: %ld for %s\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval, + PL_op_name[optype])); #ifdef DEBUG_LEAKING_SCALARS sv->sv_debug_optype = optype; sv->sv_debug_inpad = 1; @@ -809,9 +809,9 @@ Perl_pad_add_anon(pTHX_ CV* func, I32 optype) /* to avoid ref loops, we never have parent + child referencing each * other simultaneously */ if (CvOUTSIDE(func)) { - assert(!CvWEAKOUTSIDE(func)); - CvWEAKOUTSIDE_on(func); - SvREFCNT_dec_NN(CvOUTSIDE(func)); + assert(!CvWEAKOUTSIDE(func)); + CvWEAKOUTSIDE_on(func); + SvREFCNT_dec_NN(CvOUTSIDE(func)); } return ix; } @@ -862,58 +862,58 @@ S_pad_check_dup(pTHX_ PADNAME *name, U32 flags, const HV *ourstash) assert((flags & ~padadd_OUR) == 0); if (PadnamelistMAX(PL_comppad_name) < 0 || !ckWARN(WARN_SHADOW)) - return; /* nothing to check */ + return; /* nothing to check */ svp = PadnamelistARRAY(PL_comppad_name); top = PadnamelistMAX(PL_comppad_name); /* check the current scope */ for (off = top; off > PL_comppad_name_floor; off--) { - PADNAME * const sv = svp[off]; - if (sv - && PadnameLEN(sv) == PadnameLEN(name) - && !PadnameOUTER(sv) - && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO - || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) - && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name))) - { - if (is_our && (SvPAD_OUR(sv))) - break; /* "our" masking "our" */ - /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */ - Perl_warner(aTHX_ packWARN(WARN_SHADOW), - "\"%s\" %s %" PNf " masks earlier declaration in same %s", - ( is_our ? "our" : + PADNAME * const sv = svp[off]; + if (sv + && PadnameLEN(sv) == PadnameLEN(name) + && !PadnameOUTER(sv) + && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO + || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) + && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name))) + { + if (is_our && (SvPAD_OUR(sv))) + break; /* "our" masking "our" */ + /* diag_listed_as: "%s" variable %s masks earlier declaration in same %s */ + Perl_warner(aTHX_ packWARN(WARN_SHADOW), + "\"%s\" %s %" PNf " masks earlier declaration in same %s", + ( is_our ? "our" : PL_parser->in_my == KEY_my ? "my" : PL_parser->in_my == KEY_sigvar ? "my" : "state" ), - *PadnamePV(sv) == '&' ? "subroutine" : "variable", - PNfARG(sv), - (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO - ? "scope" : "statement")); - --off; - break; - } + *PadnamePV(sv) == '&' ? "subroutine" : "variable", + PNfARG(sv), + (COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO + ? "scope" : "statement")); + --off; + break; + } } /* check the rest of the pad */ if (is_our) { - while (off > 0) { - PADNAME * const sv = svp[off]; - if (sv - && PadnameLEN(sv) == PadnameLEN(name) - && !PadnameOUTER(sv) - && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO - || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) - && SvOURSTASH(sv) == ourstash - && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name))) - { - Perl_warner(aTHX_ packWARN(WARN_SHADOW), - "\"our\" variable %" PNf " redeclared", PNfARG(sv)); - if (off <= PL_comppad_name_floor) - Perl_warner(aTHX_ packWARN(WARN_SHADOW), - "\t(Did you mean \"local\" instead of \"our\"?)\n"); - break; - } - --off; - } + while (off > 0) { + PADNAME * const sv = svp[off]; + if (sv + && PadnameLEN(sv) == PadnameLEN(name) + && !PadnameOUTER(sv) + && ( COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO + || COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) + && SvOURSTASH(sv) == ourstash + && memEQ(PadnamePV(sv), PadnamePV(name), PadnameLEN(name))) + { + Perl_warner(aTHX_ packWARN(WARN_SHADOW), + "\"our\" variable %" PNf " redeclared", PNfARG(sv)); + if (off <= PL_comppad_name_floor) + Perl_warner(aTHX_ packWARN(WARN_SHADOW), + "\t(Did you mean \"local\" instead of \"our\"?)\n"); + break; + } + --off; + } } } @@ -947,8 +947,8 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) pad_peg("pad_findmy_pvn"); if (flags) - Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: pad_findmy_pvn illegal flag bits 0x%" UVxf, + (UV)flags); /* compilation errors can zero PL_compcv */ if (!PL_compcv) @@ -957,7 +957,7 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) offset = pad_findlex(namepv, namelen, flags, PL_compcv, PL_cop_seqmax, 1, NULL, &out_pn, &out_flags); if (offset != NOT_IN_PAD) - return offset; + return offset; /* Skip the ‘our’ hack for subroutines, as the warning does not apply. */ @@ -977,8 +977,8 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) && ( PadnamePV(name) == namepv || memEQ(PadnamePV(name), namepv, namelen) ) && COP_SEQ_RANGE_LOW(name) == PERL_PADSEQ_INTRO - ) - return offset; + ) + return offset; } return NOT_IN_PAD; } @@ -1088,16 +1088,16 @@ S_unavailable(pTHX_ PADNAME *name) { /* diag_listed_as: Variable "%s" is not available */ Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), - "%s \"%" PNf "\" is not available", - *PadnamePV(name) == '&' - ? "Subroutine" - : "Variable", - PNfARG(name)); + "%s \"%" PNf "\" is not available", + *PadnamePV(name) == '&' + ? "Subroutine" + : "Variable", + PNfARG(name)); } STATIC PADOFFSET S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, U32 seq, - int warn, SV** out_capture, PADNAME** out_name, int *out_flags) + int warn, SV** out_capture, PADNAME** out_name, int *out_flags) { PADOFFSET offset, new_offset; SV *new_capture; @@ -1109,226 +1109,226 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv, flags &= ~ padadd_STALEOK; /* one-shot flag */ if (flags) - Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf, - (UV)flags); + Perl_croak(aTHX_ "panic: pad_findlex illegal flag bits 0x%" UVxf, + (UV)flags); *out_flags = 0; DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n", - PTR2UV(cv), (int)namelen, namepv, (int)seq, - out_capture ? " capturing" : "" )); + "Pad findlex cv=0x%" UVxf " searching \"%.*s\" seq=%d%s\n", + PTR2UV(cv), (int)namelen, namepv, (int)seq, + out_capture ? " capturing" : "" )); /* first, search this pad */ if (padlist) { /* not an undef CV */ - PADOFFSET fake_offset = 0; + PADOFFSET fake_offset = 0; const PADNAMELIST * const names = PadlistNAMES(padlist); - PADNAME * const * const name_p = PadnamelistARRAY(names); + PADNAME * const * const name_p = PadnamelistARRAY(names); - for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) { + for (offset = PadnamelistMAXNAMED(names); offset > 0; offset--) { const PADNAME * const name = name_p[offset]; if (name && PadnameLEN(name) == namelen && ( PadnamePV(name) == namepv || memEQ(PadnamePV(name), namepv, namelen) )) - { - if (PadnameOUTER(name)) { - fake_offset = offset; /* in case we don't find a real one */ - continue; - } - if (PadnameIN_SCOPE(name, seq)) - break; - } - } - - if (offset > 0 || fake_offset > 0 ) { /* a match! */ - if (offset > 0) { /* not fake */ - fake_offset = 0; - *out_name = name_p[offset]; /* return the name */ - - /* set PAD_FAKELEX_MULTI if this lex can have multiple - * instances. For now, we just test !CvUNIQUE(cv), but - * ideally, we should detect my's declared within loops - * etc - this would allow a wider range of 'not stayed - * shared' warnings. We also treated already-compiled - * lexes as not multi as viewed from evals. */ - - *out_flags = CvANON(cv) ? - PAD_FAKELEX_ANON : - (!CvUNIQUE(cv) && ! CvCOMPILED(cv)) - ? PAD_FAKELEX_MULTI : 0; - - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n", - PTR2UV(cv), (long)offset, - (unsigned long)COP_SEQ_RANGE_LOW(*out_name), - (unsigned long)COP_SEQ_RANGE_HIGH(*out_name))); - } - else { /* fake match */ - offset = fake_offset; - *out_name = name_p[offset]; /* return the name */ - *out_flags = PARENT_FAKELEX_FLAGS(*out_name); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n", - PTR2UV(cv), (long)offset, (unsigned long)*out_flags, - (unsigned long) PARENT_PAD_INDEX(*out_name) - )); - } - - /* return the lex? */ - - if (out_capture) { - - /* our ? */ - if (PadnameIsOUR(*out_name)) { - *out_capture = NULL; - return offset; - } - - /* trying to capture from an anon prototype? */ - if (CvCOMPILED(cv) - ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv) - : *out_flags & PAD_FAKELEX_ANON) - { - if (warn) - S_unavailable(aTHX_ - *out_name); - - *out_capture = NULL; - } - - /* real value */ - else { - int newwarn = warn; - if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI) - && !PadnameIsSTATE(name_p[offset]) - && warn && ckWARN(WARN_CLOSURE)) { - newwarn = 0; - /* diag_listed_as: Variable "%s" will not stay - shared */ - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "%s \"%" UTF8f "\" will not stay shared", - *namepv == '&' ? "Subroutine" : "Variable", - UTF8fARG(1, namelen, namepv)); - } - - if (fake_offset && CvANON(cv) - && CvCLONE(cv) &&!CvCLONED(cv)) - { - PADNAME *n; - /* not yet caught - look further up */ - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n", - PTR2UV(cv))); - n = *out_name; - (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), - CvOUTSIDE_SEQ(cv), - newwarn, out_capture, out_name, out_flags); - *out_name = n; - return offset; - } - - *out_capture = AvARRAY(PadlistARRAY(padlist)[ - CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset]; - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n", - PTR2UV(cv), PTR2UV(*out_capture))); - - if (SvPADSTALE(*out_capture) - && (!CvDEPTH(cv) || !staleok) - && !PadnameIsSTATE(name_p[offset])) - { - S_unavailable(aTHX_ - name_p[offset]); - *out_capture = NULL; - } - } - if (!*out_capture) { - if (namelen != 0 && *namepv == '@') - *out_capture = sv_2mortal(MUTABLE_SV(newAV())); - else if (namelen != 0 && *namepv == '%') - *out_capture = sv_2mortal(MUTABLE_SV(newHV())); - else if (namelen != 0 && *namepv == '&') - *out_capture = sv_2mortal(newSV_type(SVt_PVCV)); - else - *out_capture = sv_newmortal(); - } - } - - return offset; - } + { + if (PadnameOUTER(name)) { + fake_offset = offset; /* in case we don't find a real one */ + continue; + } + if (PadnameIN_SCOPE(name, seq)) + break; + } + } + + if (offset > 0 || fake_offset > 0 ) { /* a match! */ + if (offset > 0) { /* not fake */ + fake_offset = 0; + *out_name = name_p[offset]; /* return the name */ + + /* set PAD_FAKELEX_MULTI if this lex can have multiple + * instances. For now, we just test !CvUNIQUE(cv), but + * ideally, we should detect my's declared within loops + * etc - this would allow a wider range of 'not stayed + * shared' warnings. We also treated already-compiled + * lexes as not multi as viewed from evals. */ + + *out_flags = CvANON(cv) ? + PAD_FAKELEX_ANON : + (!CvUNIQUE(cv) && ! CvCOMPILED(cv)) + ? PAD_FAKELEX_MULTI : 0; + + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%" UVxf " matched: offset=%ld (%lu,%lu)\n", + PTR2UV(cv), (long)offset, + (unsigned long)COP_SEQ_RANGE_LOW(*out_name), + (unsigned long)COP_SEQ_RANGE_HIGH(*out_name))); + } + else { /* fake match */ + offset = fake_offset; + *out_name = name_p[offset]; /* return the name */ + *out_flags = PARENT_FAKELEX_FLAGS(*out_name); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%" UVxf " matched: offset=%ld flags=0x%lx index=%lu\n", + PTR2UV(cv), (long)offset, (unsigned long)*out_flags, + (unsigned long) PARENT_PAD_INDEX(*out_name) + )); + } + + /* return the lex? */ + + if (out_capture) { + + /* our ? */ + if (PadnameIsOUR(*out_name)) { + *out_capture = NULL; + return offset; + } + + /* trying to capture from an anon prototype? */ + if (CvCOMPILED(cv) + ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv) + : *out_flags & PAD_FAKELEX_ANON) + { + if (warn) + S_unavailable(aTHX_ + *out_name); + + *out_capture = NULL; + } + + /* real value */ + else { + int newwarn = warn; + if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI) + && !PadnameIsSTATE(name_p[offset]) + && warn && ckWARN(WARN_CLOSURE)) { + newwarn = 0; + /* diag_listed_as: Variable "%s" will not stay + shared */ + Perl_warner(aTHX_ packWARN(WARN_CLOSURE), + "%s \"%" UTF8f "\" will not stay shared", + *namepv == '&' ? "Subroutine" : "Variable", + UTF8fARG(1, namelen, namepv)); + } + + if (fake_offset && CvANON(cv) + && CvCLONE(cv) &&!CvCLONED(cv)) + { + PADNAME *n; + /* not yet caught - look further up */ + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%" UVxf " chasing lex in outer pad\n", + PTR2UV(cv))); + n = *out_name; + (void) pad_findlex(namepv, namelen, flags, CvOUTSIDE(cv), + CvOUTSIDE_SEQ(cv), + newwarn, out_capture, out_name, out_flags); + *out_name = n; + return offset; + } + + *out_capture = AvARRAY(PadlistARRAY(padlist)[ + CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset]; + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%" UVxf " found lex=0x%" UVxf "\n", + PTR2UV(cv), PTR2UV(*out_capture))); + + if (SvPADSTALE(*out_capture) + && (!CvDEPTH(cv) || !staleok) + && !PadnameIsSTATE(name_p[offset])) + { + S_unavailable(aTHX_ + name_p[offset]); + *out_capture = NULL; + } + } + if (!*out_capture) { + if (namelen != 0 && *namepv == '@') + *out_capture = sv_2mortal(MUTABLE_SV(newAV())); + else if (namelen != 0 && *namepv == '%') + *out_capture = sv_2mortal(MUTABLE_SV(newHV())); + else if (namelen != 0 && *namepv == '&') + *out_capture = sv_2mortal(newSV_type(SVt_PVCV)); + else + *out_capture = sv_newmortal(); + } + } + + return offset; + } } /* it's not in this pad - try above */ if (!CvOUTSIDE(cv)) - return NOT_IN_PAD; + return NOT_IN_PAD; /* out_capture non-null means caller wants us to capture lex; in * addition we capture ourselves unless it's an ANON/format */ new_capturep = out_capture ? out_capture : - CvLATE(cv) ? NULL : &new_capture; + CvLATE(cv) ? NULL : &new_capture; offset = pad_findlex(namepv, namelen, - flags | padadd_STALEOK*(new_capturep == &new_capture), - CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, - new_capturep, out_name, out_flags); + flags | padadd_STALEOK*(new_capturep == &new_capture), + CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1, + new_capturep, out_name, out_flags); if (offset == NOT_IN_PAD) - return NOT_IN_PAD; + return NOT_IN_PAD; /* found in an outer CV. Add appropriate fake entry to this pad */ /* don't add new fake entries (via eval) to CVs that we have already * finished compiling, or to undef CVs */ if (CvCOMPILED(cv) || !padlist) - return 0; /* this dummy (and invalid) value isnt used by the caller */ + return 0; /* this dummy (and invalid) value isnt used by the caller */ { - PADNAME *new_name = newPADNAMEouter(*out_name); - PADNAMELIST * const ocomppad_name = PL_comppad_name; - PAD * const ocomppad = PL_comppad; - PL_comppad_name = PadlistNAMES(padlist); - PL_comppad = PadlistARRAY(padlist)[1]; - PL_curpad = AvARRAY(PL_comppad); - - new_offset - = pad_alloc_name(new_name, - PadnameIsSTATE(*out_name) ? padadd_STATE : 0, - PadnameTYPE(*out_name), - PadnameOURSTASH(*out_name) - ); - - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad addname: %ld \"%.*s\" FAKE\n", - (long)new_offset, - (int) PadnameLEN(new_name), - PadnamePV(new_name))); - PARENT_FAKELEX_FLAGS_set(new_name, *out_flags); - - PARENT_PAD_INDEX_set(new_name, 0); - if (PadnameIsOUR(new_name)) { - NOOP; /* do nothing */ - } - else if (CvLATE(cv)) { - /* delayed creation - just note the offset within parent pad */ - PARENT_PAD_INDEX_set(new_name, offset); - CvCLONE_on(cv); - } - else { - /* immediate creation - capture outer value right now */ - av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep)); - /* But also note the offset, as newMYSUB needs it */ - PARENT_PAD_INDEX_set(new_name, offset); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n", - PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset)); - } - *out_name = new_name; - *out_flags = PARENT_FAKELEX_FLAGS(new_name); - - PL_comppad_name = ocomppad_name; - PL_comppad = ocomppad; - PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL; + PADNAME *new_name = newPADNAMEouter(*out_name); + PADNAMELIST * const ocomppad_name = PL_comppad_name; + PAD * const ocomppad = PL_comppad; + PL_comppad_name = PadlistNAMES(padlist); + PL_comppad = PadlistARRAY(padlist)[1]; + PL_curpad = AvARRAY(PL_comppad); + + new_offset + = pad_alloc_name(new_name, + PadnameIsSTATE(*out_name) ? padadd_STATE : 0, + PadnameTYPE(*out_name), + PadnameOURSTASH(*out_name) + ); + + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad addname: %ld \"%.*s\" FAKE\n", + (long)new_offset, + (int) PadnameLEN(new_name), + PadnamePV(new_name))); + PARENT_FAKELEX_FLAGS_set(new_name, *out_flags); + + PARENT_PAD_INDEX_set(new_name, 0); + if (PadnameIsOUR(new_name)) { + NOOP; /* do nothing */ + } + else if (CvLATE(cv)) { + /* delayed creation - just note the offset within parent pad */ + PARENT_PAD_INDEX_set(new_name, offset); + CvCLONE_on(cv); + } + else { + /* immediate creation - capture outer value right now */ + av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep)); + /* But also note the offset, as newMYSUB needs it */ + PARENT_PAD_INDEX_set(new_name, offset); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad findlex cv=0x%" UVxf " saved captured sv 0x%" UVxf " at offset %ld\n", + PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset)); + } + *out_name = new_name; + *out_flags = PARENT_FAKELEX_FLAGS(new_name); + + PL_comppad_name = ocomppad_name; + PL_comppad = ocomppad; + PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL; } return new_offset; } @@ -1350,10 +1350,10 @@ Perl_pad_sv(pTHX_ PADOFFSET po) ASSERT_CURPAD_ACTIVE("pad_sv"); if (!po) - Perl_croak(aTHX_ "panic: pad_sv po"); + Perl_croak(aTHX_ "panic: pad_sv po"); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po])) + "Pad 0x%" UVxf "[0x%" UVxf "] sv: %ld sv=0x%" UVxf "\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(PL_curpad[po])) ); return PL_curpad[po]; } @@ -1375,8 +1375,8 @@ Perl_pad_setsv(pTHX_ PADOFFSET po, SV* sv) ASSERT_CURPAD_ACTIVE("pad_setsv"); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv)) + "Pad 0x%" UVxf "[0x%" UVxf "] setsv: %ld sv=0x%" UVxf "\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po, PTR2UV(sv)) ); PL_curpad[po] = sv; } @@ -1398,9 +1398,9 @@ Perl_pad_block_start(pTHX_ int full) save_strlen((STRLEN *)&PL_comppad_name_floor); PL_comppad_name_floor = PadnamelistMAX(PL_comppad_name); if (full) - PL_comppad_name_fill = PL_comppad_name_floor; + PL_comppad_name_fill = PL_comppad_name_floor; if (PL_comppad_name_floor < 0) - PL_comppad_name_floor = 0; + PL_comppad_name_floor = 0; save_strlen((STRLEN *)&PL_min_intro_pending); save_strlen((STRLEN *)&PL_max_intro_pending); PL_min_intro_pending = 0; @@ -1409,7 +1409,7 @@ Perl_pad_block_start(pTHX_ int full) /* PL_padix_floor is what PL_padix is reset to at the start of each statement, by pad_reset(). We set it when entering a new scope to keep things like this working: - print "$foo$bar", do { this(); that() . "foo" }; + print "$foo$bar", do { this(); that() . "foo" }; We must not let "$foo$bar" and the later concatenation share the same target. */ PL_padix_floor = PL_padix; @@ -1435,36 +1435,36 @@ Perl_intro_my(pTHX) ASSERT_CURPAD_ACTIVE("intro_my"); if (PL_compiling.cop_seq) { - seq = PL_compiling.cop_seq; - PL_compiling.cop_seq = 0; + seq = PL_compiling.cop_seq; + PL_compiling.cop_seq = 0; } else - seq = PL_cop_seqmax; + seq = PL_cop_seqmax; if (! PL_min_intro_pending) - return seq; + return seq; svp = PadnamelistARRAY(PL_comppad_name); for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { - PADNAME * const sv = svp[i]; - - if (sv && PadnameLEN(sv) && !PadnameOUTER(sv) - && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO) - { - COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */ - COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad intromy: %ld \"%s\", (%lu,%lu)\n", - (long)i, PadnamePV(sv), - (unsigned long)COP_SEQ_RANGE_LOW(sv), - (unsigned long)COP_SEQ_RANGE_HIGH(sv)) - ); - } + PADNAME * const sv = svp[i]; + + if (sv && PadnameLEN(sv) && !PadnameOUTER(sv) + && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO) + { + COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */ + COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad intromy: %ld \"%s\", (%lu,%lu)\n", + (long)i, PadnamePV(sv), + (unsigned long)COP_SEQ_RANGE_LOW(sv), + (unsigned long)COP_SEQ_RANGE_HIGH(sv)) + ); + } } COP_SEQMAX_INC; PL_min_intro_pending = 0; PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */ DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax))); + "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax))); return seq; } @@ -1489,39 +1489,39 @@ Perl_pad_leavemy(pTHX) ASSERT_CURPAD_ACTIVE("pad_leavemy"); if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) { - for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { - const PADNAME * const name = svp[off]; - if (name && PadnameLEN(name) && !PadnameOUTER(name)) - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "%" PNf " never introduced", - PNfARG(name)); - } + for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { + const PADNAME * const name = svp[off]; + if (name && PadnameLEN(name) && !PadnameOUTER(name)) + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "%" PNf " never introduced", + PNfARG(name)); + } } /* "Deintroduce" my variables that are leaving with this scope. */ for (off = PadnamelistMAX(PL_comppad_name); - off > PL_comppad_name_fill; off--) { - PADNAME * const sv = svp[off]; - if (sv && PadnameLEN(sv) && !PadnameOUTER(sv) - && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) - { - COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", - (long)off, PadnamePV(sv), - (unsigned long)COP_SEQ_RANGE_LOW(sv), - (unsigned long)COP_SEQ_RANGE_HIGH(sv)) - ); - if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) - && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) { - OP *kid = newOP(OP_INTROCV, 0); - kid->op_targ = off; - o = op_prepend_elem(OP_LINESEQ, kid, o); - } - } + off > PL_comppad_name_fill; off--) { + PADNAME * const sv = svp[off]; + if (sv && PadnameLEN(sv) && !PadnameOUTER(sv) + && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) + { + COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", + (long)off, PadnamePV(sv), + (unsigned long)COP_SEQ_RANGE_LOW(sv), + (unsigned long)COP_SEQ_RANGE_HIGH(sv)) + ); + if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) + && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) { + OP *kid = newOP(OP_INTROCV, 0); + kid->op_targ = off; + o = op_prepend_elem(OP_LINESEQ, kid, o); + } + } } COP_SEQMAX_INC; DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); + "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); return o; } @@ -1539,20 +1539,20 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) { ASSERT_CURPAD_LEGAL("pad_swipe"); if (!PL_curpad) - return; + return; if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p", - AvARRAY(PL_comppad), PL_curpad); + Perl_croak(aTHX_ "panic: pad_swipe curpad, %p!=%p", + AvARRAY(PL_comppad), PL_curpad); if (!po || ((SSize_t)po) > AvFILLp(PL_comppad)) - Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld", - (long)po, (long)AvFILLp(PL_comppad)); + Perl_croak(aTHX_ "panic: pad_swipe po=%ld, fill=%ld", + (long)po, (long)AvFILLp(PL_comppad)); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)); + "Pad 0x%" UVxf "[0x%" UVxf "] swipe: %ld\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po)); if (refadjust) - SvREFCNT_dec(PL_curpad[po]); + SvREFCNT_dec(PL_curpad[po]); /* if pad tmps aren't shared between ops, then there's no need to @@ -1565,16 +1565,16 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) #endif if (PadnamelistMAX(PL_comppad_name) != -1 && (PADOFFSET)PadnamelistMAX(PL_comppad_name) >= po) { - if (PadnamelistARRAY(PL_comppad_name)[po]) { - assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po])); - } - PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef; + if (PadnamelistARRAY(PL_comppad_name)[po]) { + assert(!PadnameLEN(PadnamelistARRAY(PL_comppad_name)[po])); + } + PadnamelistARRAY(PL_comppad_name)[po] = &PL_padname_undef; } /* Use PL_constpadix here, not PL_padix. The latter may have been reset by pad_reset. We don’t want pad_alloc to have to scan the whole pad when allocating a constant. */ if (po < PL_constpadix) - PL_constpadix = po - 1; + PL_constpadix = po - 1; } /* @@ -1595,18 +1595,18 @@ S_pad_reset(pTHX) { #ifdef USE_PAD_RESET if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p", - AvARRAY(PL_comppad), PL_curpad); + Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p", + AvARRAY(PL_comppad), PL_curpad); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), - (long)PL_padix, (long)PL_padix_floor - ) + "Pad 0x%" UVxf "[0x%" UVxf "] reset: padix %ld -> %ld", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), + (long)PL_padix, (long)PL_padix_floor + ) ); if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */ - PL_padix = PL_padix_floor; + PL_padix = PL_padix_floor; } #endif PL_pad_reset_pending = FALSE; @@ -1652,79 +1652,79 @@ Perl_pad_tidy(pTHX_ padtidy_type type) if (PL_cv_has_eval || PL_perldb) { const CV *cv; - for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) { - if (cv != PL_compcv && CvCOMPILED(cv)) - break; /* no need to mark already-compiled code */ - if (CvANON(cv)) { - DEBUG_Xv(PerlIO_printf(Perl_debug_log, - "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv))); - CvCLONE_on(cv); - } - CvHASEVAL_on(cv); - } + for (cv = PL_compcv ;cv; cv = CvOUTSIDE(cv)) { + if (cv != PL_compcv && CvCOMPILED(cv)) + break; /* no need to mark already-compiled code */ + if (CvANON(cv)) { + DEBUG_Xv(PerlIO_printf(Perl_debug_log, + "Pad clone on cv=0x%" UVxf "\n", PTR2UV(cv))); + CvCLONE_on(cv); + } + CvHASEVAL_on(cv); + } } /* extend namepad to match curpad */ if (PadnamelistMAX(PL_comppad_name) < AvFILLp(PL_comppad)) - padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL); + padnamelist_store(PL_comppad_name, AvFILLp(PL_comppad), NULL); if (type == padtidy_SUBCLONE) { - PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name); - PADOFFSET ix; - - for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - PADNAME *namesv; - if (!namep[ix]) namep[ix] = &PL_padname_undef; - - /* - * The only things that a clonable function needs in its - * pad are anonymous subs, constants and GVs. - * The rest are created anew during cloning. - */ - if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])) - continue; - namesv = namep[ix]; - if (!(PadnamePV(namesv) && - (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&'))) - { - SvREFCNT_dec(PL_curpad[ix]); - PL_curpad[ix] = NULL; - } - } + PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name); + PADOFFSET ix; + + for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { + PADNAME *namesv; + if (!namep[ix]) namep[ix] = &PL_padname_undef; + + /* + * The only things that a clonable function needs in its + * pad are anonymous subs, constants and GVs. + * The rest are created anew during cloning. + */ + if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])) + continue; + namesv = namep[ix]; + if (!(PadnamePV(namesv) && + (!PadnameLEN(namesv) || *PadnamePV(namesv) == '&'))) + { + SvREFCNT_dec(PL_curpad[ix]); + PL_curpad[ix] = NULL; + } + } } else if (type == padtidy_SUB) { - AV * const av = newAV(); /* Will be @_ */ - av_store(PL_comppad, 0, MUTABLE_SV(av)); - AvREIFY_only(av); + AV * const av = newAV(); /* Will be @_ */ + av_store(PL_comppad, 0, MUTABLE_SV(av)); + AvREIFY_only(av); } if (type == padtidy_SUB || type == padtidy_FORMAT) { - PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name); - PADOFFSET ix; - for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - if (!namep[ix]) namep[ix] = &PL_padname_undef; - if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])) - continue; - if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) { - /* This is a work around for how the current implementation of - ?{ } blocks in regexps interacts with lexicals. - - One of our lexicals. - Can't do this on all lexicals, otherwise sub baz() won't - compile in - - my $foo; - - sub bar { ++$foo; } - - sub baz { ++$foo; } - - because completion of compiling &bar calling pad_tidy() - would cause (top level) $foo to be marked as stale, and - "no longer available". */ - SvPADSTALE_on(PL_curpad[ix]); - } - } + PADNAME ** const namep = PadnamelistARRAY(PL_comppad_name); + PADOFFSET ix; + for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { + if (!namep[ix]) namep[ix] = &PL_padname_undef; + if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])) + continue; + if (SvPADMY(PL_curpad[ix]) && !PadnameOUTER(namep[ix])) { + /* This is a work around for how the current implementation of + ?{ } blocks in regexps interacts with lexicals. + + One of our lexicals. + Can't do this on all lexicals, otherwise sub baz() won't + compile in + + my $foo; + + sub bar { ++$foo; } + + sub baz { ++$foo; } + + because completion of compiling &bar calling pad_tidy() + would cause (top level) $foo to be marked as stale, and + "no longer available". */ + SvPADSTALE_on(PL_curpad[ix]); + } + } } PL_curpad = AvARRAY(PL_comppad); } @@ -1745,25 +1745,25 @@ Perl_pad_free(pTHX_ PADOFFSET po) #endif ASSERT_CURPAD_LEGAL("pad_free"); if (!PL_curpad) - return; + return; if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p", - AvARRAY(PL_comppad), PL_curpad); + Perl_croak(aTHX_ "panic: pad_free curpad, %p!=%p", + AvARRAY(PL_comppad), PL_curpad); if (!po) - Perl_croak(aTHX_ "panic: pad_free po"); + Perl_croak(aTHX_ "panic: pad_free po"); DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n", - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po) + "Pad 0x%" UVxf "[0x%" UVxf "] free: %ld\n", + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po) ); #ifndef USE_PAD_RESET sv = PL_curpad[po]; if (sv && sv != &PL_sv_undef && !SvPADMY(sv)) - SvFLAGS(sv) &= ~SVs_PADTMP; + SvFLAGS(sv) &= ~SVs_PADTMP; if (po < PL_padix) - PL_padix = po - 1; + PL_padix = po - 1; #endif } @@ -1787,53 +1787,53 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full) PERL_ARGS_ASSERT_DO_DUMP_PAD; if (!padlist) { - return; + return; } pad_name = PadlistNAMES(padlist); pad = PadlistARRAY(padlist)[1]; pname = PadnamelistARRAY(pad_name); ppad = AvARRAY(pad); Perl_dump_indent(aTHX_ level, file, - "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n", - PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad) + "PADNAME = 0x%" UVxf "(0x%" UVxf ") PAD = 0x%" UVxf "(0x%" UVxf ")\n", + PTR2UV(pad_name), PTR2UV(pname), PTR2UV(pad), PTR2UV(ppad) ); for (ix = 1; ix <= PadnamelistMAX(pad_name); ix++) { const PADNAME *namesv = pname[ix]; - if (namesv && !PadnameLEN(namesv)) { - namesv = NULL; - } - if (namesv) { - if (PadnameOUTER(namesv)) - Perl_dump_indent(aTHX_ level+1, file, - "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n", - (int) ix, - PTR2UV(ppad[ix]), - (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), - PadnamePV(namesv), - (unsigned long)PARENT_FAKELEX_FLAGS(namesv), - (unsigned long)PARENT_PAD_INDEX(namesv) - - ); - else - Perl_dump_indent(aTHX_ level+1, file, - "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n", - (int) ix, - PTR2UV(ppad[ix]), - (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), - (unsigned long)COP_SEQ_RANGE_LOW(namesv), - (unsigned long)COP_SEQ_RANGE_HIGH(namesv), - PadnamePV(namesv) - ); - } - else if (full) { - Perl_dump_indent(aTHX_ level+1, file, - "%2d. 0x%" UVxf "<%lu>\n", - (int) ix, - PTR2UV(ppad[ix]), - (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0) - ); - } + if (namesv && !PadnameLEN(namesv)) { + namesv = NULL; + } + if (namesv) { + if (PadnameOUTER(namesv)) + Perl_dump_indent(aTHX_ level+1, file, + "%2d. 0x%" UVxf "<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n", + (int) ix, + PTR2UV(ppad[ix]), + (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), + PadnamePV(namesv), + (unsigned long)PARENT_FAKELEX_FLAGS(namesv), + (unsigned long)PARENT_PAD_INDEX(namesv) + + ); + else + Perl_dump_indent(aTHX_ level+1, file, + "%2d. 0x%" UVxf "<%lu> (%lu,%lu) \"%s\"\n", + (int) ix, + PTR2UV(ppad[ix]), + (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0), + (unsigned long)COP_SEQ_RANGE_LOW(namesv), + (unsigned long)COP_SEQ_RANGE_HIGH(namesv), + PadnamePV(namesv) + ); + } + else if (full) { + Perl_dump_indent(aTHX_ level+1, file, + "%2d. 0x%" UVxf "<%lu>\n", + (int) ix, + PTR2UV(ppad[ix]), + (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0) + ); + } } } @@ -1856,23 +1856,23 @@ S_cv_dump(pTHX_ const CV *cv, const char *title) PERL_ARGS_ASSERT_CV_DUMP; PerlIO_printf(Perl_debug_log, - " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n", - title, - PTR2UV(cv), - (CvANON(cv) ? "ANON" - : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT" - : (cv == PL_main_cv) ? "MAIN" - : CvUNIQUE(cv) ? "UNIQUE" - : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"), - PTR2UV(outside), - (!outside ? "null" - : CvANON(outside) ? "ANON" - : (outside == PL_main_cv) ? "MAIN" - : CvUNIQUE(outside) ? "UNIQUE" - : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); + " %s: CV=0x%" UVxf " (%s), OUTSIDE=0x%" UVxf " (%s)\n", + title, + PTR2UV(cv), + (CvANON(cv) ? "ANON" + : (SvTYPE(cv) == SVt_PVFM) ? "FORMAT" + : (cv == PL_main_cv) ? "MAIN" + : CvUNIQUE(cv) ? "UNIQUE" + : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"), + PTR2UV(outside), + (!outside ? "null" + : CvANON(outside) ? "ANON" + : (outside == PL_main_cv) ? "MAIN" + : CvUNIQUE(outside) ? "UNIQUE" + : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); PerlIO_printf(Perl_debug_log, - " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist)); + " PADLIST = 0x%" UVxf "\n", PTR2UV(padlist)); do_dump_pad(1, Perl_debug_log, padlist, 1); } @@ -1894,7 +1894,7 @@ static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned); static CV * S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, - bool newcv) + bool newcv) { PADOFFSET ix; PADLIST* const protopadlist = CvPADLIST(proto); @@ -1923,22 +1923,22 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, if (!outside) { if (CvWEAKOUTSIDE(proto)) - outside = find_runcv(NULL); + outside = find_runcv(NULL); else { - outside = CvOUTSIDE(proto); - if ((CvCLONE(outside) && ! CvCLONED(outside)) - || !CvPADLIST(outside) - || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) { - outside = find_runcv_where( - FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL - ); - /* outside could be null */ - } + outside = CvOUTSIDE(proto); + if ((CvCLONE(outside) && ! CvCLONED(outside)) + || !CvPADLIST(outside) + || CvPADLIST(outside)->xpadl_id != protopadlist->xpadl_outid) { + outside = find_runcv_where( + FIND_RUNCV_padid_eq, PTR2IV(protopadlist->xpadl_outid), NULL + ); + /* outside could be null */ + } } } depth = outside ? CvDEPTH(outside) : 0; if (!depth) - depth = 1; + depth = 1; ENTER; SAVESPTR(PL_compcv); @@ -1946,7 +1946,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, if (newcv) SAVEFREESV(cv); /* in case of fatal warnings */ if (CvHASEVAL(cv)) - CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); + CvOUTSIDE(cv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); SAVESPTR(PL_comppad_name); PL_comppad_name = protopad_name; @@ -1958,226 +1958,226 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned, PL_curpad = AvARRAY(PL_comppad); outpad = outside && CvPADLIST(outside) - ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth]) - : NULL; + ? AvARRAY(PadlistARRAY(CvPADLIST(outside))[depth]) + : NULL; if (outpad) CvPADLIST(cv)->xpadl_outid = CvPADLIST(outside)->xpadl_id; for (ix = fpad; ix > 0; ix--) { - PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL; - SV *sv = NULL; - if (namesv && PadnameLEN(namesv)) { /* lexical */ - if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */ - NOOP; - } - else { - if (PadnameOUTER(namesv)) { /* lexical from outside? */ - /* formats may have an inactive, or even undefined, parent; - but state vars are always available. */ - if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)]) - || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv) - && (!outside || !CvDEPTH(outside))) ) { - S_unavailable(aTHX_ namesv); - sv = NULL; - } - else - SvREFCNT_inc_simple_void_NN(sv); - } - if (!sv) { + PADNAME* const namesv = (ix <= fname) ? pname[ix] : NULL; + SV *sv = NULL; + if (namesv && PadnameLEN(namesv)) { /* lexical */ + if (PadnameIsOUR(namesv)) { /* or maybe not so lexical */ + NOOP; + } + else { + if (PadnameOUTER(namesv)) { /* lexical from outside? */ + /* formats may have an inactive, or even undefined, parent; + but state vars are always available. */ + if (!outpad || !(sv = outpad[PARENT_PAD_INDEX(namesv)]) + || ( SvPADSTALE(sv) && !SvPAD_STATE(namesv) + && (!outside || !CvDEPTH(outside))) ) { + S_unavailable(aTHX_ namesv); + sv = NULL; + } + else + SvREFCNT_inc_simple_void_NN(sv); + } + if (!sv) { const char sigil = PadnamePV(namesv)[0]; if (sigil == '&') - /* If there are state subs, we need to clone them, too. - But they may need to close over variables we have - not cloned yet. So we will have to do a second - pass. Furthermore, there may be state subs clos- - ing over other state subs’ entries, so we have - to put a stub here and then clone into it on the - second pass. */ - if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) { - assert(SvTYPE(ppad[ix]) == SVt_PVCV); - subclones ++; - if (CvOUTSIDE(ppad[ix]) != proto) - trouble = TRUE; - sv = newSV_type(SVt_PVCV); - CvLEXICAL_on(sv); - } - else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv)) - { - /* my sub */ - /* Just provide a stub, but name it. It will be - upgraded to the real thing on scope entry. */ - U32 hash; - PERL_HASH(hash, PadnamePV(namesv)+1, - PadnameLEN(namesv) - 1); - sv = newSV_type(SVt_PVCV); - CvNAME_HEK_set( - sv, - share_hek(PadnamePV(namesv)+1, - 1 - PadnameLEN(namesv), - hash) - ); - CvLEXICAL_on(sv); - } - else sv = SvREFCNT_inc(ppad[ix]); + /* If there are state subs, we need to clone them, too. + But they may need to close over variables we have + not cloned yet. So we will have to do a second + pass. Furthermore, there may be state subs clos- + ing over other state subs’ entries, so we have + to put a stub here and then clone into it on the + second pass. */ + if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) { + assert(SvTYPE(ppad[ix]) == SVt_PVCV); + subclones ++; + if (CvOUTSIDE(ppad[ix]) != proto) + trouble = TRUE; + sv = newSV_type(SVt_PVCV); + CvLEXICAL_on(sv); + } + else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv)) + { + /* my sub */ + /* Just provide a stub, but name it. It will be + upgraded to the real thing on scope entry. */ + U32 hash; + PERL_HASH(hash, PadnamePV(namesv)+1, + PadnameLEN(namesv) - 1); + sv = newSV_type(SVt_PVCV); + CvNAME_HEK_set( + sv, + share_hek(PadnamePV(namesv)+1, + 1 - PadnameLEN(namesv), + hash) + ); + CvLEXICAL_on(sv); + } + else sv = SvREFCNT_inc(ppad[ix]); else if (sigil == '@') - sv = MUTABLE_SV(newAV()); + sv = MUTABLE_SV(newAV()); else if (sigil == '%') - sv = MUTABLE_SV(newHV()); - else - sv = newSV(0); - /* reset the 'assign only once' flag on each state var */ - if (sigil != '&' && SvPAD_STATE(namesv)) - SvPADSTALE_on(sv); - } - } - } - else if (namesv && PadnamePV(namesv)) { - sv = SvREFCNT_inc_NN(ppad[ix]); - } - else { - sv = newSV(0); - SvPADTMP_on(sv); - } - PL_curpad[ix] = sv; + sv = MUTABLE_SV(newHV()); + else + sv = newSV(0); + /* reset the 'assign only once' flag on each state var */ + if (sigil != '&' && SvPAD_STATE(namesv)) + SvPADSTALE_on(sv); + } + } + } + else if (namesv && PadnamePV(namesv)) { + sv = SvREFCNT_inc_NN(ppad[ix]); + } + else { + sv = newSV(0); + SvPADTMP_on(sv); + } + PL_curpad[ix] = sv; } if (subclones) { - if (trouble || cloned) { - /* Uh-oh, we have trouble! At least one of the state subs here - has its CvOUTSIDE pointer pointing somewhere unexpected. It - could be pointing to another state protosub that we are - about to clone. So we have to track which sub clones come - from which protosubs. If the CvOUTSIDE pointer for a parti- - cular sub points to something we have not cloned yet, we - delay cloning it. We must loop through the pad entries, - until we get a full pass with no cloning. If any uncloned - subs remain (probably nested inside anonymous or ‘my’ subs), - then they get cloned in a final pass. - */ - bool cloned_in_this_pass; - if (!cloned) - cloned = (HV *)sv_2mortal((SV *)newHV()); - do { - cloned_in_this_pass = FALSE; - for (ix = fpad; ix > 0; ix--) { - PADNAME * const name = - (ix <= fname) ? pname[ix] : NULL; - if (name && name != &PL_padname_undef - && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' - && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) - { - CV * const protokey = CvOUTSIDE(ppad[ix]); - CV ** const cvp = protokey == proto - ? &cv - : (CV **)hv_fetch(cloned, (char *)&protokey, - sizeof(CV *), 0); - if (cvp && *cvp) { - S_cv_clone(aTHX_ (CV *)ppad[ix], - (CV *)PL_curpad[ix], - *cvp, cloned); - (void)hv_store(cloned, (char *)&ppad[ix], - sizeof(CV *), - SvREFCNT_inc_simple_NN(PL_curpad[ix]), - 0); - subclones--; - cloned_in_this_pass = TRUE; - } - } - } - } while (cloned_in_this_pass); - if (subclones) - for (ix = fpad; ix > 0; ix--) { - PADNAME * const name = - (ix <= fname) ? pname[ix] : NULL; - if (name && name != &PL_padname_undef - && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' - && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) - S_cv_clone(aTHX_ (CV *)ppad[ix], - (CV *)PL_curpad[ix], - CvOUTSIDE(ppad[ix]), cloned); - } - } - else for (ix = fpad; ix > 0; ix--) { - PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; - if (name && name != &PL_padname_undef && !PadnameOUTER(name) - && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name)) - S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv, - NULL); - } + if (trouble || cloned) { + /* Uh-oh, we have trouble! At least one of the state subs here + has its CvOUTSIDE pointer pointing somewhere unexpected. It + could be pointing to another state protosub that we are + about to clone. So we have to track which sub clones come + from which protosubs. If the CvOUTSIDE pointer for a parti- + cular sub points to something we have not cloned yet, we + delay cloning it. We must loop through the pad entries, + until we get a full pass with no cloning. If any uncloned + subs remain (probably nested inside anonymous or ‘my’ subs), + then they get cloned in a final pass. + */ + bool cloned_in_this_pass; + if (!cloned) + cloned = (HV *)sv_2mortal((SV *)newHV()); + do { + cloned_in_this_pass = FALSE; + for (ix = fpad; ix > 0; ix--) { + PADNAME * const name = + (ix <= fname) ? pname[ix] : NULL; + if (name && name != &PL_padname_undef + && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' + && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) + { + CV * const protokey = CvOUTSIDE(ppad[ix]); + CV ** const cvp = protokey == proto + ? &cv + : (CV **)hv_fetch(cloned, (char *)&protokey, + sizeof(CV *), 0); + if (cvp && *cvp) { + S_cv_clone(aTHX_ (CV *)ppad[ix], + (CV *)PL_curpad[ix], + *cvp, cloned); + (void)hv_store(cloned, (char *)&ppad[ix], + sizeof(CV *), + SvREFCNT_inc_simple_NN(PL_curpad[ix]), + 0); + subclones--; + cloned_in_this_pass = TRUE; + } + } + } + } while (cloned_in_this_pass); + if (subclones) + for (ix = fpad; ix > 0; ix--) { + PADNAME * const name = + (ix <= fname) ? pname[ix] : NULL; + if (name && name != &PL_padname_undef + && !PadnameOUTER(name) && PadnamePV(name)[0] == '&' + && PadnameIsSTATE(name) && !CvCLONED(PL_curpad[ix])) + S_cv_clone(aTHX_ (CV *)ppad[ix], + (CV *)PL_curpad[ix], + CvOUTSIDE(ppad[ix]), cloned); + } + } + else for (ix = fpad; ix > 0; ix--) { + PADNAME * const name = (ix <= fname) ? pname[ix] : NULL; + if (name && name != &PL_padname_undef && !PadnameOUTER(name) + && PadnamePV(name)[0] == '&' && PadnameIsSTATE(name)) + S_cv_clone(aTHX_ (CV *)ppad[ix], (CV *)PL_curpad[ix], cv, + NULL); + } } if (newcv) SvREFCNT_inc_simple_void_NN(cv); LEAVE; if (CvCONST(cv)) { - /* Constant sub () { $x } closing over $x: - * The prototype was marked as a candiate for const-ization, - * so try to grab the current const value, and if successful, - * turn into a const sub: - */ - SV* const_sv; - OP *o = CvSTART(cv); - assert(newcv); - for (; o; o = o->op_next) - if (o->op_type == OP_PADSV) - break; - ASSUME(o->op_type == OP_PADSV); - const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); - /* the candidate should have 1 ref from this pad and 1 ref - * from the parent */ - if (const_sv && SvREFCNT(const_sv) == 2) { - const bool was_method = cBOOL(CvMETHOD(cv)); - if (outside) { - PADNAME * const pn = - PadlistNAMESARRAY(CvPADLIST(outside)) - [PARENT_PAD_INDEX(PadlistNAMESARRAY( - CvPADLIST(cv))[o->op_targ])]; - assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv)) - [o->op_targ])); - if (PadnameLVALUE(pn)) { - /* We have a lexical that is potentially modifiable - elsewhere, so making a constant will break clo- - sure behaviour. If this is a ‘simple lexical - op tree’, i.e., sub(){$x}, emit a deprecation - warning, but continue to exhibit the old behav- - iour of making it a constant based on the ref- - count of the candidate variable. - - A simple lexical op tree looks like this: - - leavesub - lineseq - nextstate - padsv - */ - if (OpSIBLING( - cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first - ) == o - && !OpSIBLING(o)) - { + /* Constant sub () { $x } closing over $x: + * The prototype was marked as a candiate for const-ization, + * so try to grab the current const value, and if successful, + * turn into a const sub: + */ + SV* const_sv; + OP *o = CvSTART(cv); + assert(newcv); + for (; o; o = o->op_next) + if (o->op_type == OP_PADSV) + break; + ASSUME(o->op_type == OP_PADSV); + const_sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); + /* the candidate should have 1 ref from this pad and 1 ref + * from the parent */ + if (const_sv && SvREFCNT(const_sv) == 2) { + const bool was_method = cBOOL(CvMETHOD(cv)); + if (outside) { + PADNAME * const pn = + PadlistNAMESARRAY(CvPADLIST(outside)) + [PARENT_PAD_INDEX(PadlistNAMESARRAY( + CvPADLIST(cv))[o->op_targ])]; + assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv)) + [o->op_targ])); + if (PadnameLVALUE(pn)) { + /* We have a lexical that is potentially modifiable + elsewhere, so making a constant will break clo- + sure behaviour. If this is a ‘simple lexical + op tree’, i.e., sub(){$x}, emit a deprecation + warning, but continue to exhibit the old behav- + iour of making it a constant based on the ref- + count of the candidate variable. + + A simple lexical op tree looks like this: + + leavesub + lineseq + nextstate + padsv + */ + if (OpSIBLING( + cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first + ) == o + && !OpSIBLING(o)) + { Perl_croak(aTHX_ "Constants from lexical variables potentially modified " "elsewhere are no longer permitted"); - } - else - goto constoff; - } - } + } + else + goto constoff; + } + } SvREFCNT_inc_simple_void_NN(const_sv); - /* If the lexical is not used elsewhere, it is safe to turn on - SvPADTMP, since it is only when it is used in lvalue con- - text that the difference is observable. */ - SvREADONLY_on(const_sv); - SvPADTMP_on(const_sv); - SvREFCNT_dec_NN(cv); - cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv); - if (was_method) - CvMETHOD_on(cv); - } - else { - constoff: - CvCONST_off(cv); - } + /* If the lexical is not used elsewhere, it is safe to turn on + SvPADTMP, since it is only when it is used in lvalue con- + text that the difference is observable. */ + SvREADONLY_on(const_sv); + SvPADTMP_on(const_sv); + SvREFCNT_dec_NN(cv); + cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv); + if (was_method) + CvMETHOD_on(cv); + } + else { + constoff: + CvCONST_off(cv); + } } return cv; @@ -2192,13 +2192,13 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned) if (!cv) cv = MUTABLE_CV(newSV_type(SvTYPE(proto))); CvFLAGS(cv) = CvFLAGS(proto) & ~(CVf_CLONE|CVf_WEAKOUTSIDE|CVf_CVGV_RC - |CVf_SLABBED); + |CVf_SLABBED); CvCLONED_on(cv); CvFILE(cv) = CvDYNFILE(proto) ? savepv(CvFILE(proto)) - : CvFILE(proto); + : CvFILE(proto); if (CvNAMED(proto)) - CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto))); + CvNAME_HEK_set(cv, share_hek_hek(CvNAME_HEK(proto))); else CvGV_set(cv,CvGV(proto)); CvSTASH_set(cv, CvSTASH(proto)); OP_REFCNT_LOCK; @@ -2208,21 +2208,21 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside, HV *cloned) CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(proto); if (SvPOK(proto)) { - sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); + sv_setpvn(MUTABLE_SV(cv), SvPVX_const(proto), SvCUR(proto)); if (SvUTF8(proto)) SvUTF8_on(MUTABLE_SV(cv)); } if (SvMAGIC(proto)) - mg_copy((SV *)proto, (SV *)cv, 0, 0); + mg_copy((SV *)proto, (SV *)cv, 0, 0); if (CvPADLIST(proto)) - cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv); + cv = S_cv_clone_pad(aTHX_ proto, cv, outside, cloned, newcv); DEBUG_Xv( - PerlIO_printf(Perl_debug_log, "\nPad CV clone\n"); - if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside"); - cv_dump(proto, "Proto"); - cv_dump(cv, "To"); + PerlIO_printf(Perl_debug_log, "\nPad CV clone\n"); + if (CvOUTSIDE(cv)) cv_dump(CvOUTSIDE(cv), "Outside"); + cv_dump(proto, "Proto"); + cv_dump(cv, "To"); ); return cv; @@ -2272,31 +2272,31 @@ Perl_cv_name(pTHX_ CV *cv, SV *sv, U32 flags) { PERL_ARGS_ASSERT_CV_NAME; if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) { - if (sv) sv_setsv(sv,(SV *)cv); - return sv ? (sv) : (SV *)cv; + if (sv) sv_setsv(sv,(SV *)cv); + return sv ? (sv) : (SV *)cv; } { - SV * const retsv = sv ? (sv) : sv_newmortal(); - if (SvTYPE(cv) == SVt_PVCV) { - if (CvNAMED(cv)) { - if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) - sv_sethek(retsv, CvNAME_HEK(cv)); - else { - if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv))) - sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv))); - else - sv_setpvs(retsv, "__ANON__"); - sv_catpvs(retsv, "::"); - sv_cathek(retsv, CvNAME_HEK(cv)); - } - } - else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) - sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv)))); - else gv_efullname3(retsv, CvGV(cv), NULL); - } - else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv)); - else gv_efullname3(retsv,(GV *)cv,NULL); - return retsv; + SV * const retsv = sv ? (sv) : sv_newmortal(); + if (SvTYPE(cv) == SVt_PVCV) { + if (CvNAMED(cv)) { + if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) + sv_sethek(retsv, CvNAME_HEK(cv)); + else { + if (CvSTASH(cv) && HvNAME_HEK(CvSTASH(cv))) + sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv))); + else + sv_setpvs(retsv, "__ANON__"); + sv_catpvs(retsv, "::"); + sv_cathek(retsv, CvNAME_HEK(cv)); + } + } + else if (CvLEXICAL(cv) || flags & CV_NAME_NOTQUAL) + sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv)))); + else gv_efullname3(retsv, CvGV(cv), NULL); + } + else if (flags & CV_NAME_NOTQUAL) sv_sethek(retsv, GvNAME_HEK(cv)); + else gv_efullname3(retsv,(GV *)cv,NULL); + return retsv; } } @@ -2324,51 +2324,51 @@ Perl_pad_fixup_inner_anons(pTHX_ PADLIST *padlist, CV *old_cv, CV *new_cv) for (ix = PadnamelistMAX(comppad_name); ix > 0; ix--) { const PADNAME *name = namepad[ix]; - if (name && name != &PL_padname_undef && !PadnameIsOUR(name) - && *PadnamePV(name) == '&') - { - CV *innercv = MUTABLE_CV(curpad[ix]); - if (UNLIKELY(PadnameOUTER(name))) { - CV *cv = new_cv; - PADNAME **names = namepad; - PADOFFSET i = ix; - while (PadnameOUTER(name)) { - assert(SvTYPE(cv) == SVt_PVCV); - cv = CvOUTSIDE(cv); - names = PadlistNAMESARRAY(CvPADLIST(cv)); - i = PARENT_PAD_INDEX(name); - name = names[i]; - } - innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i]; - } - if (SvTYPE(innercv) == SVt_PVCV) { - /* XXX 0afba48f added code here to check for a proto CV - attached to the pad entry by magic. But shortly there- - after 81df9f6f95 moved the magic to the pad name. The - code here was never updated, so it wasn’t doing anything - and got deleted when PADNAME became a distinct type. Is - there any bug as a result? */ - if (CvOUTSIDE(innercv) == old_cv) { - if (!CvWEAKOUTSIDE(innercv)) { - SvREFCNT_dec(old_cv); - SvREFCNT_inc_simple_void_NN(new_cv); - } - CvOUTSIDE(innercv) = new_cv; - } - } - else { /* format reference */ - SV * const rv = curpad[ix]; - CV *innercv; - if (!SvOK(rv)) continue; - assert(SvROK(rv)); - assert(SvWEAKREF(rv)); - innercv = (CV *)SvRV(rv); - assert(!CvWEAKOUTSIDE(innercv)); - assert(CvOUTSIDE(innercv) == old_cv); - SvREFCNT_dec(CvOUTSIDE(innercv)); - CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv); - } - } + if (name && name != &PL_padname_undef && !PadnameIsOUR(name) + && *PadnamePV(name) == '&') + { + CV *innercv = MUTABLE_CV(curpad[ix]); + if (UNLIKELY(PadnameOUTER(name))) { + CV *cv = new_cv; + PADNAME **names = namepad; + PADOFFSET i = ix; + while (PadnameOUTER(name)) { + assert(SvTYPE(cv) == SVt_PVCV); + cv = CvOUTSIDE(cv); + names = PadlistNAMESARRAY(CvPADLIST(cv)); + i = PARENT_PAD_INDEX(name); + name = names[i]; + } + innercv = (CV *)PadARRAY(PadlistARRAY(CvPADLIST(cv))[1])[i]; + } + if (SvTYPE(innercv) == SVt_PVCV) { + /* XXX 0afba48f added code here to check for a proto CV + attached to the pad entry by magic. But shortly there- + after 81df9f6f95 moved the magic to the pad name. The + code here was never updated, so it wasn’t doing anything + and got deleted when PADNAME became a distinct type. Is + there any bug as a result? */ + if (CvOUTSIDE(innercv) == old_cv) { + if (!CvWEAKOUTSIDE(innercv)) { + SvREFCNT_dec(old_cv); + SvREFCNT_inc_simple_void_NN(new_cv); + } + CvOUTSIDE(innercv) = new_cv; + } + } + else { /* format reference */ + SV * const rv = curpad[ix]; + CV *innercv; + if (!SvOK(rv)) continue; + assert(SvROK(rv)); + assert(SvWEAKREF(rv)); + innercv = (CV *)SvRV(rv); + assert(!CvWEAKOUTSIDE(innercv)); + assert(CvOUTSIDE(innercv) == old_cv); + SvREFCNT_dec(CvOUTSIDE(innercv)); + CvOUTSIDE(innercv) = (CV *)SvREFCNT_inc_simple_NN(new_cv); + } + } } } @@ -2388,50 +2388,50 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) PERL_ARGS_ASSERT_PAD_PUSH; if (depth > PadlistMAX(padlist) || !PadlistARRAY(padlist)[depth]) { - PAD** const svp = PadlistARRAY(padlist); - AV* const newpad = newAV(); - SV** const oldpad = AvARRAY(svp[depth-1]); - PADOFFSET ix = AvFILLp((const AV *)svp[1]); - const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]); - PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]); - AV *av; - - for ( ;ix > 0; ix--) { - if (names_fill >= ix && PadnameLEN(names[ix])) { - const char sigil = PadnamePV(names[ix])[0]; - if (PadnameOUTER(names[ix]) - || PadnameIsSTATE(names[ix]) - || sigil == '&') - { - /* outer lexical or anon code */ - av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); - } - else { /* our own lexical */ - SV *sv; - if (sigil == '@') - sv = MUTABLE_SV(newAV()); - else if (sigil == '%') - sv = MUTABLE_SV(newHV()); - else - sv = newSV(0); - av_store(newpad, ix, sv); - } - } - else if (PadnamePV(names[ix])) { - av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix])); - } - else { - /* save temporaries on recursion? */ - SV * const sv = newSV(0); - av_store(newpad, ix, sv); - SvPADTMP_on(sv); - } - } - av = newAV(); - av_store(newpad, 0, MUTABLE_SV(av)); - AvREIFY_only(av); - - padlist_store(padlist, depth, newpad); + PAD** const svp = PadlistARRAY(padlist); + AV* const newpad = newAV(); + SV** const oldpad = AvARRAY(svp[depth-1]); + PADOFFSET ix = AvFILLp((const AV *)svp[1]); + const PADOFFSET names_fill = PadnamelistMAX((PADNAMELIST *)svp[0]); + PADNAME ** const names = PadnamelistARRAY((PADNAMELIST *)svp[0]); + AV *av; + + for ( ;ix > 0; ix--) { + if (names_fill >= ix && PadnameLEN(names[ix])) { + const char sigil = PadnamePV(names[ix])[0]; + if (PadnameOUTER(names[ix]) + || PadnameIsSTATE(names[ix]) + || sigil == '&') + { + /* outer lexical or anon code */ + av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); + } + else { /* our own lexical */ + SV *sv; + if (sigil == '@') + sv = MUTABLE_SV(newAV()); + else if (sigil == '%') + sv = MUTABLE_SV(newHV()); + else + sv = newSV(0); + av_store(newpad, ix, sv); + } + } + else if (PadnamePV(names[ix])) { + av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix])); + } + else { + /* save temporaries on recursion? */ + SV * const sv = newSV(0); + av_store(newpad, ix, sv); + SvPADTMP_on(sv); + } + } + av = newAV(); + av_store(newpad, 0, MUTABLE_SV(av)); + AvREIFY_only(av); + + padlist_store(padlist, depth, newpad); } } @@ -2467,89 +2467,89 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) Newx(PadlistARRAY(dstpad), max + 1, PAD *); PadlistARRAY(dstpad)[0] = (PAD *) - padnamelist_dup(PadlistNAMES(srcpad), param); + padnamelist_dup(PadlistNAMES(srcpad), param); PadnamelistREFCNT(PadlistNAMES(dstpad))++; if (cloneall) { - PADOFFSET depth; - for (depth = 1; depth <= max; ++depth) - PadlistARRAY(dstpad)[depth] = - av_dup_inc(PadlistARRAY(srcpad)[depth], param); + PADOFFSET depth; + for (depth = 1; depth <= max; ++depth) + PadlistARRAY(dstpad)[depth] = + av_dup_inc(PadlistARRAY(srcpad)[depth], param); } else { - /* CvDEPTH() on our subroutine will be set to 0, so there's no need - to build anything other than the first level of pads. */ - PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]); - AV *pad1; - const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad)); - const PAD *const srcpad1 = PadlistARRAY(srcpad)[1]; - SV **oldpad = AvARRAY(srcpad1); - PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad)); - SV **pad1a; - AV *args; - - pad1 = newAV(); - - av_extend(pad1, ix); - PadlistARRAY(dstpad)[1] = pad1; - pad1a = AvARRAY(pad1); - - if (ix > -1) { - AvFILLp(pad1) = ix; - - for ( ;ix > 0; ix--) { - if (!oldpad[ix]) { - pad1a[ix] = NULL; - } else if (names_fill >= ix && names[ix] && - PadnameLEN(names[ix])) { - const char sigil = PadnamePV(names[ix])[0]; - if (PadnameOUTER(names[ix]) - || PadnameIsSTATE(names[ix]) - || sigil == '&') - { - /* outer lexical or anon code */ - pad1a[ix] = sv_dup_inc(oldpad[ix], param); - } - else { /* our own lexical */ - if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) { - /* This is a work around for how the current - implementation of ?{ } blocks in regexps - interacts with lexicals. */ - pad1a[ix] = sv_dup_inc(oldpad[ix], param); - } else { - SV *sv; - - if (sigil == '@') - sv = MUTABLE_SV(newAV()); - else if (sigil == '%') - sv = MUTABLE_SV(newHV()); - else - sv = newSV(0); - pad1a[ix] = sv; - } - } - } - else if (( names_fill >= ix && names[ix] - && PadnamePV(names[ix]) )) { - pad1a[ix] = sv_dup_inc(oldpad[ix], param); - } - else { - /* save temporaries on recursion? */ - SV * const sv = newSV(0); - pad1a[ix] = sv; - - /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs - FIXTHAT before merging this branch. - (And I know how to) */ - if (SvPADTMP(oldpad[ix])) - SvPADTMP_on(sv); - } - } - - if (oldpad[0]) { - args = newAV(); /* Will be @_ */ - AvREIFY_only(args); - pad1a[0] = (SV *)args; - } - } + /* CvDEPTH() on our subroutine will be set to 0, so there's no need + to build anything other than the first level of pads. */ + PADOFFSET ix = AvFILLp(PadlistARRAY(srcpad)[1]); + AV *pad1; + const PADOFFSET names_fill = PadnamelistMAX(PadlistNAMES(srcpad)); + const PAD *const srcpad1 = PadlistARRAY(srcpad)[1]; + SV **oldpad = AvARRAY(srcpad1); + PADNAME ** const names = PadnamelistARRAY(PadlistNAMES(dstpad)); + SV **pad1a; + AV *args; + + pad1 = newAV(); + + av_extend(pad1, ix); + PadlistARRAY(dstpad)[1] = pad1; + pad1a = AvARRAY(pad1); + + if (ix > -1) { + AvFILLp(pad1) = ix; + + for ( ;ix > 0; ix--) { + if (!oldpad[ix]) { + pad1a[ix] = NULL; + } else if (names_fill >= ix && names[ix] && + PadnameLEN(names[ix])) { + const char sigil = PadnamePV(names[ix])[0]; + if (PadnameOUTER(names[ix]) + || PadnameIsSTATE(names[ix]) + || sigil == '&') + { + /* outer lexical or anon code */ + pad1a[ix] = sv_dup_inc(oldpad[ix], param); + } + else { /* our own lexical */ + if(SvPADSTALE(oldpad[ix]) && SvREFCNT(oldpad[ix]) > 1) { + /* This is a work around for how the current + implementation of ?{ } blocks in regexps + interacts with lexicals. */ + pad1a[ix] = sv_dup_inc(oldpad[ix], param); + } else { + SV *sv; + + if (sigil == '@') + sv = MUTABLE_SV(newAV()); + else if (sigil == '%') + sv = MUTABLE_SV(newHV()); + else + sv = newSV(0); + pad1a[ix] = sv; + } + } + } + else if (( names_fill >= ix && names[ix] + && PadnamePV(names[ix]) )) { + pad1a[ix] = sv_dup_inc(oldpad[ix], param); + } + else { + /* save temporaries on recursion? */ + SV * const sv = newSV(0); + pad1a[ix] = sv; + + /* SvREFCNT(oldpad[ix]) != 1 for some code in threads.xs + FIXTHAT before merging this branch. + (And I know how to) */ + if (SvPADTMP(oldpad[ix])) + SvPADTMP_on(sv); + } + } + + if (oldpad[0]) { + args = newAV(); /* Will be @_ */ + AvREIFY_only(args); + pad1a[0] = (SV *)args; + } + } } return dstpad; @@ -2568,11 +2568,11 @@ Perl_padlist_store(pTHX_ PADLIST *padlist, I32 key, PAD *val) assert(key >= 0); if (key > PadlistMAX(padlist)) { - av_extend_guts(NULL,key,&PadlistMAX(padlist), - (SV ***)&PadlistARRAY(padlist), - (SV ***)&PadlistARRAY(padlist)); - Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax, - PAD *); + av_extend_guts(NULL,key,&PadlistMAX(padlist), + (SV ***)&PadlistARRAY(padlist), + (SV ***)&PadlistARRAY(padlist)); + Zero(PadlistARRAY(padlist)+oldmax+1, PadlistMAX(padlist)-oldmax, + PAD *); } ary = PadlistARRAY(padlist); SvREFCNT_dec(ary[key]); @@ -2621,17 +2621,17 @@ Perl_padnamelist_store(pTHX_ PADNAMELIST *pnl, SSize_t key, PADNAME *val) assert(key >= 0); if (key > pnl->xpadnl_max) - av_extend_guts(NULL,key,&pnl->xpadnl_max, - (SV ***)&PadnamelistARRAY(pnl), - (SV ***)&PadnamelistARRAY(pnl)); + av_extend_guts(NULL,key,&pnl->xpadnl_max, + (SV ***)&PadnamelistARRAY(pnl), + (SV ***)&PadnamelistARRAY(pnl)); if (PadnamelistMAX(pnl) < key) { - Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1, - key-PadnamelistMAX(pnl), PADNAME *); - PadnamelistMAX(pnl) = key; + Zero(PadnamelistARRAY(pnl)+PadnamelistMAX(pnl)+1, + key-PadnamelistMAX(pnl), PADNAME *); + PadnamelistMAX(pnl) = key; } ary = PadnamelistARRAY(pnl); if (ary[key]) - PadnameREFCNT_dec(ary[key]); + PadnameREFCNT_dec(ary[key]); ary[key] = val; return &ary[key]; } @@ -2658,15 +2658,15 @@ Perl_padnamelist_free(pTHX_ PADNAMELIST *pnl) { PERL_ARGS_ASSERT_PADNAMELIST_FREE; if (!--PadnamelistREFCNT(pnl)) { - while(PadnamelistMAX(pnl) >= 0) - { - PADNAME * const pn = - PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--]; - if (pn) - PadnameREFCNT_dec(pn); - } - Safefree(PadnamelistARRAY(pnl)); - Safefree(pnl); + while(PadnamelistMAX(pnl) >= 0) + { + PADNAME * const pn = + PadnamelistARRAY(pnl)[PadnamelistMAX(pnl)--]; + if (pn) + PadnameREFCNT_dec(pn); + } + Safefree(PadnamelistARRAY(pnl)); + Safefree(pnl); } } @@ -2691,7 +2691,7 @@ Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param) /* look for it in the table first */ dstpad = (PADNAMELIST *)ptr_table_fetch(PL_ptr_table, srcpad); if (dstpad) - return dstpad; + return dstpad; dstpad = newPADNAMELIST(max); PadnamelistREFCNT(dstpad) = 0; /* The caller will increment it. */ @@ -2701,9 +2701,9 @@ Perl_padnamelist_dup(pTHX_ PADNAMELIST *srcpad, CLONE_PARAMS *param) ptr_table_store(PL_ptr_table, srcpad, dstpad); for (; max >= 0; max--) if (PadnamelistARRAY(srcpad)[max]) { - PadnamelistARRAY(dstpad)[max] = - padname_dup(PadnamelistARRAY(srcpad)[max], param); - PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++; + PadnamelistARRAY(dstpad)[max] = + padname_dup(PadnamelistARRAY(srcpad)[max], param); + PadnameREFCNT(PadnamelistARRAY(dstpad)[max])++; } return dstpad; @@ -2729,8 +2729,8 @@ Perl_newPADNAMEpvn(const char *s, STRLEN len) PADNAME *pn; PERL_ARGS_ASSERT_NEWPADNAMEPVN; Newxz(alloc2, - STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1, - char); + STRUCT_OFFSET(struct padname_with_str, xpadn_str[0]) + len + 1, + char); alloc = (struct padname_with_str *)alloc2; pn = (PADNAME *)alloc; PadnameREFCNT(pn) = 1; @@ -2775,15 +2775,15 @@ Perl_padname_free(pTHX_ PADNAME *pn) { PERL_ARGS_ASSERT_PADNAME_FREE; if (!--PadnameREFCNT(pn)) { - if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) { - PadnameREFCNT(pn) = SvREFCNT_IMMORTAL; - return; - } - SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */ - SvREFCNT_dec(PadnameOURSTASH(pn)); - if (PadnameOUTER(pn)) - PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn))); - Safefree(pn); + if (UNLIKELY(pn == &PL_padname_undef || pn == &PL_padname_const)) { + PadnameREFCNT(pn) = SvREFCNT_IMMORTAL; + return; + } + SvREFCNT_dec(PadnameTYPE(pn)); /* Takes care of protocv, too. */ + SvREFCNT_dec(PadnameOURSTASH(pn)); + if (PadnameOUTER(pn)) + PadnameREFCNT_dec(PADNAME_FROM_PV(PadnamePV(pn))); + Safefree(pn); } } @@ -2807,12 +2807,12 @@ Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param) /* look for it in the table first */ dst = (PADNAME *)ptr_table_fetch(PL_ptr_table, src); if (dst) - return dst; + return dst; if (!PadnamePV(src)) { - dst = &PL_padname_undef; - ptr_table_store(PL_ptr_table, src, dst); - return dst; + dst = &PL_padname_undef; + ptr_table_store(PL_ptr_table, src, dst); + return dst; } dst = PadnameOUTER(src) @@ -2824,7 +2824,7 @@ Perl_padname_dup(pTHX_ PADNAME *src, CLONE_PARAMS *param) PadnameREFCNT(dst) = 0; /* The caller will increment it. */ PadnameTYPE (dst) = (HV *)sv_dup_inc((SV *)PadnameTYPE(src), param); PadnameOURSTASH(dst) = (HV *)sv_dup_inc((SV *)PadnameOURSTASH(src), - param); + param); dst->xpadn_low = src->xpadn_low; dst->xpadn_high = src->xpadn_high; dst->xpadn_gen = src->xpadn_gen; @@ -23,13 +23,13 @@ typedef SSize_t PADOFFSET; /* signed so that -1 is a valid value */ struct padlist { SSize_t xpadl_max; /* max index for which array has space */ union { - PAD ** xpadlarr_alloc; /* Pointer to beginning of array of AVs. - index 0 is a padnamelist * */ - struct { - PADNAMELIST * padnl; - PAD * pad_1; /* this slice of PAD * array always alloced */ - PAD * pad_2; /* maybe unalloced */ - } * xpadlarr_dbg; /* for use with a C debugger only */ + PAD ** xpadlarr_alloc; /* Pointer to beginning of array of AVs. + index 0 is a padnamelist * */ + struct { + PADNAMELIST * padnl; + PAD * pad_1; /* this slice of PAD * array always alloced */ + PAD * pad_2; /* maybe unalloced */ + } * xpadlarr_dbg; /* for use with a C debugger only */ } xpadl_arr; U32 xpadl_id; /* Semi-unique ID, shared between clones */ U32 xpadl_outid; /* ID of outer pad */ @@ -58,8 +58,8 @@ struct padnamelist { char * xpadn_pv; \ HV * xpadn_ourstash; \ union { \ - HV * xpadn_typestash; \ - CV * xpadn_protocv; \ + HV * xpadn_typestash; \ + CV * xpadn_protocv; \ } xpadn_type_u; \ U32 xpadn_low; \ U32 xpadn_high; \ @@ -92,8 +92,8 @@ struct padname_with_str { */ #define PERL_PADSEQ_INTRO U32_MAX #define COP_SEQMAX_INC \ - (PL_cop_seqmax++, \ - (void)(PL_cop_seqmax == PERL_PADSEQ_INTRO && PL_cop_seqmax++)) + (PL_cop_seqmax++, \ + (void)(PL_cop_seqmax == PERL_PADSEQ_INTRO && PL_cop_seqmax++)) /* B.xs needs these for the benefit of B::Deparse */ @@ -119,9 +119,9 @@ struct padname_with_str { /* values for the pad_tidy() function */ typedef enum { - padtidy_SUB, /* tidy up a pad for a sub, */ - padtidy_SUBCLONE, /* a cloned sub, */ - padtidy_FORMAT /* or a format */ + padtidy_SUB, /* tidy up a pad for a sub, */ + padtidy_SUBCLONE, /* a cloned sub, */ + padtidy_FORMAT /* or a format */ } padtidy_type; /* flags for pad_add_name_pvn. */ @@ -130,7 +130,7 @@ typedef enum { #define padadd_STATE 0x02 /* state declaration. */ #define padadd_NO_DUP_CHECK 0x04 /* skip warning on dups. */ #define padadd_STALEOK 0x08 /* allow stale lexical in active - * sub, but only one level up */ + * sub, but only one level up */ /* ASSERT_CURPAD_LEGAL and ASSERT_CURPAD_ACTIVE respectively determine * whether PL_comppad and PL_curpad are consistent and whether they have @@ -142,15 +142,15 @@ typedef enum { # define ASSERT_CURPAD_LEGAL(label) \ pad_peg(label); \ if (PL_comppad ? (AvARRAY(PL_comppad) != PL_curpad) : (PL_curpad != 0)) \ - Perl_croak(aTHX_ "panic: illegal pad in %s: 0x%" UVxf "[0x%" UVxf "]",\ - label, PTR2UV(PL_comppad), PTR2UV(PL_curpad)); + Perl_croak(aTHX_ "panic: illegal pad in %s: 0x%" UVxf "[0x%" UVxf "]",\ + label, PTR2UV(PL_comppad), PTR2UV(PL_curpad)); # define ASSERT_CURPAD_ACTIVE(label) \ pad_peg(label); \ if (!PL_comppad || (AvARRAY(PL_comppad) != PL_curpad)) \ - Perl_croak(aTHX_ "panic: invalid pad in %s: 0x%" UVxf "[0x%" UVxf "]",\ - label, PTR2UV(PL_comppad), PTR2UV(PL_curpad)); + Perl_croak(aTHX_ "panic: invalid pad in %s: 0x%" UVxf "[0x%" UVxf "]",\ + label, PTR2UV(PL_comppad), PTR2UV(PL_curpad)); #else # define ASSERT_CURPAD_LEGAL(label) # define ASSERT_CURPAD_ACTIVE(label) @@ -313,7 +313,7 @@ Restore the old pad saved into the local variable C<opad> by C<PAD_SAVE_LOCAL()> #define PadnameLEN(pn) (pn)->xpadn_len #define PadnameUTF8(pn) 1 #define PadnameSV(pn) \ - newSVpvn_flags(PadnamePV(pn), PadnameLEN(pn), SVs_TEMP|SVf_UTF8) + newSVpvn_flags(PadnamePV(pn), PadnameLEN(pn), SVs_TEMP|SVf_UTF8) #define PadnameFLAGS(pn) (pn)->xpadn_flags #define PadnameIsOUR(pn) (!!(pn)->xpadn_ourstash) #define PadnameOURSTASH(pn) (pn)->xpadn_ourstash @@ -360,43 +360,43 @@ Restore the old pad saved into the local variable C<opad> by C<PAD_SAVE_LOCAL()> #define PAD_SVl(po) (PL_curpad[po]) #define PAD_BASE_SV(padlist, po) \ - (PadlistARRAY(padlist)[1]) \ - ? AvARRAY(MUTABLE_AV((PadlistARRAY(padlist)[1])))[po] \ - : NULL; + (PadlistARRAY(padlist)[1]) \ + ? AvARRAY(MUTABLE_AV((PadlistARRAY(padlist)[1])))[po] \ + : NULL; #define PAD_SET_CUR_NOSAVE(padlist,nth) \ - PL_comppad = (PAD*) (PadlistARRAY(padlist)[nth]); \ - PL_curpad = AvARRAY(PL_comppad); \ - DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ - "Pad 0x%" UVxf "[0x%" UVxf "] set_cur depth=%d\n", \ - PTR2UV(PL_comppad), PTR2UV(PL_curpad), (int)(nth))); + PL_comppad = (PAD*) (PadlistARRAY(padlist)[nth]); \ + PL_curpad = AvARRAY(PL_comppad); \ + DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ + "Pad 0x%" UVxf "[0x%" UVxf "] set_cur depth=%d\n", \ + PTR2UV(PL_comppad), PTR2UV(PL_curpad), (int)(nth))); #define PAD_SET_CUR(padlist,nth) \ - SAVECOMPPAD(); \ - PAD_SET_CUR_NOSAVE(padlist,nth); + SAVECOMPPAD(); \ + PAD_SET_CUR_NOSAVE(padlist,nth); #define PAD_SAVE_SETNULLPAD() SAVECOMPPAD(); \ - PL_comppad = NULL; PL_curpad = NULL; \ - DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad set_null\n")); + PL_comppad = NULL; PL_curpad = NULL; \ + DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad set_null\n")); #define PAD_SAVE_LOCAL(opad,npad) \ - opad = PL_comppad; \ - PL_comppad = (npad); \ - PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \ - DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ - "Pad 0x%" UVxf "[0x%" UVxf "] save_local\n", \ - PTR2UV(PL_comppad), PTR2UV(PL_curpad))); + opad = PL_comppad; \ + PL_comppad = (npad); \ + PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \ + DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ + "Pad 0x%" UVxf "[0x%" UVxf "] save_local\n", \ + PTR2UV(PL_comppad), PTR2UV(PL_curpad))); #define PAD_RESTORE_LOCAL(opad) \ assert(!opad || !SvIS_FREED(opad)); \ - PL_comppad = opad; \ - PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \ - DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ - "Pad 0x%" UVxf "[0x%" UVxf "] restore_local\n", \ - PTR2UV(PL_comppad), PTR2UV(PL_curpad))); + PL_comppad = opad; \ + PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \ + DEBUG_Xv(PerlIO_printf(Perl_debug_log, \ + "Pad 0x%" UVxf "[0x%" UVxf "] restore_local\n", \ + PTR2UV(PL_comppad), PTR2UV(PL_curpad))); /* @@ -479,7 +479,7 @@ Clone the state variables associated with running and compiling pads. PL_comppad = av_dup(proto_perl->Icomppad, param); \ PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL; \ PL_comppad_name = \ - padnamelist_dup(proto_perl->Icomppad_name, param); \ + padnamelist_dup(proto_perl->Icomppad_name, param); \ PL_comppad_name_fill = proto_perl->Icomppad_name_fill; \ PL_comppad_name_floor = proto_perl->Icomppad_name_floor; \ PL_min_intro_pending = proto_perl->Imin_intro_pending; \ @@ -56,7 +56,7 @@ typedef struct yy_parser { char *lex_casestack; /* what kind of case mods in effect */ U8 lex_defer; /* state after determined token */ U8 lex_dojoin; /* doing an array interpolation - 1 = @{...} 2 = ->@ */ + 1 = @{...} 2 = ->@ */ U8 expect; /* how to interpret ambiguous tokens */ bool preambled; bool sub_no_recover; /* can't recover from a sublex error */ @@ -81,8 +81,8 @@ typedef struct yy_parser { LEXSHARED *lex_shared; SV *linestr; /* current chunk of src text */ char *bufptr; /* carries the cursor (current parsing - position) from one invocation of yylex - to the next */ + position) from one invocation of yylex + to the next */ char *oldbufptr; /* in yylex, beginning of current token */ char *oldoldbufptr; /* in yylex, beginning of previous token */ char *bufend; @@ -137,8 +137,8 @@ typedef struct yy_parser { # define LEX_START_COPIED 0x00000008 # define LEX_DONT_CLOSE_RSFP 0x00000010 # define LEX_START_FLAGS \ - (LEX_START_SAME_FILTER|LEX_START_COPIED \ - |LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES|LEX_DONT_CLOSE_RSFP) + (LEX_START_SAME_FILTER|LEX_START_COPIED \ + |LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES|LEX_DONT_CLOSE_RSFP) #endif /* flags for parser API */ diff --git a/patchlevel.h b/patchlevel.h index 77bc59cfcb..7803e0ebdb 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -71,42 +71,42 @@ Instead use one of the version comparison macros. See C<L</PERL_VERSION_EQ>>. #endif /* - local_patches -- list of locally applied less-than-subversion patches. - If you're distributing such a patch, please give it a name and a - one-line description, placed just before the last NULL in the array - below. If your patch fixes a bug in the perlbug database, please - mention the bugid. If your patch *IS* dependent on a prior patch, - please place your applied patch line after its dependencies. This - will help tracking of patch dependencies. - - Please either use 'diff --unified=0' if your diff supports - that or edit the hunk of the diff output which adds your patch - to this list, to remove context lines which would give patch - problems. For instance, if the original context diff is - - *** patchlevel.h.orig <date here> - --- patchlevel.h <date here> - *** 38,43 *** - --- 38,44 --- - ,"FOO1235 - some patch" - ,"BAR3141 - another patch" - ,"BAZ2718 - and another patch" - + ,"MINE001 - my new patch" - ,NULL - }; - - please change it to - *** patchlevel.h.orig <date here> - --- patchlevel.h <date here> - *** 41,43 *** - --- 41,44 --- - + ,"MINE001 - my new patch" - ,NULL - }; - - (Note changes to line numbers as well as removal of context lines.) - This will prevent patch from choking if someone has previously - applied different patches than you. + local_patches -- list of locally applied less-than-subversion patches. + If you're distributing such a patch, please give it a name and a + one-line description, placed just before the last NULL in the array + below. If your patch fixes a bug in the perlbug database, please + mention the bugid. If your patch *IS* dependent on a prior patch, + please place your applied patch line after its dependencies. This + will help tracking of patch dependencies. + + Please either use 'diff --unified=0' if your diff supports + that or edit the hunk of the diff output which adds your patch + to this list, to remove context lines which would give patch + problems. For instance, if the original context diff is + + *** patchlevel.h.orig <date here> + --- patchlevel.h <date here> + *** 38,43 *** + --- 38,44 --- + ,"FOO1235 - some patch" + ,"BAR3141 - another patch" + ,"BAZ2718 - and another patch" + + ,"MINE001 - my new patch" + ,NULL + }; + + please change it to + *** patchlevel.h.orig <date here> + --- patchlevel.h <date here> + *** 41,43 *** + --- 41,44 --- + + ,"MINE001 - my new patch" + ,NULL + }; + + (Note changes to line numbers as well as removal of context lines.) + This will prevent patch from choking if someone has previously + applied different patches than you. History has shown that nobody distributes patches that also modify patchlevel.h. Do it yourself. The following perl @@ -120,8 +120,8 @@ my $seen=0; while (<PLIN>) { if (/\t,NULL/ and $seen) { while (my $c = shift @ARGV){ - $c =~ s|\\|\\\\|g; - $c =~ s|"|\\"|g; + $c =~ s|\\|\\\\|g; + $c =~ s|"|\\"|g; print PLOUT qq{\t,"$c"\n}; } } @@ -156,19 +156,19 @@ hunk. #include "git_version.h" # endif static const char * const local_patches[] = { - NULL + NULL #ifdef PERL_GIT_UNCOMMITTED_CHANGES - ,"uncommitted-changes" + ,"uncommitted-changes" #endif - PERL_GIT_UNPUSHED_COMMITS /* do not remove this line */ - ,NULL + PERL_GIT_UNPUSHED_COMMITS /* do not remove this line */ + ,NULL }; /* Initial space prevents this variable from being inserted in config.sh */ # define LOCAL_PATCH_COUNT \ - ((int)(C_ARRAY_LENGTH(local_patches)-2)) + ((int)(C_ARRAY_LENGTH(local_patches)-2)) /* the old terms of reference, add them only when explicitly included */ #define PATCHLEVEL PERL_VERSION diff --git a/perl_inc_macro.h b/perl_inc_macro.h index 5a2f20dfae..b9cd60947e 100644 --- a/perl_inc_macro.h +++ b/perl_inc_macro.h @@ -24,7 +24,7 @@ #ifdef APPLLIB_EXP # define INCPUSH_APPLLIB_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), \ - INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); #endif #ifdef SITEARCH_EXP @@ -32,7 +32,7 @@ * DLL-based path intuition to work correctly */ # if !defined(WIN32) # define INCPUSH_SITEARCH_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP), \ - INCPUSH_CAN_RELOCATE); + INCPUSH_CAN_RELOCATE); # endif #endif @@ -40,10 +40,10 @@ # if defined(WIN32) /* this picks up sitearch as well */ # define INCPUSH_SITELIB_EXP s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len); \ - if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); + if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else # define INCPUSH_SITELIB_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), \ - INCPUSH_CAN_RELOCATE); + INCPUSH_CAN_RELOCATE); # endif #endif @@ -59,7 +59,7 @@ # if defined(WIN32) /* this picks up vendorarch as well */ # define INCPUSH_PERL_VENDORLIB_EXP s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len); \ - if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); + if (s) incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); # else # define INCPUSH_PERL_VENDORLIB_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP), INCPUSH_CAN_RELOCATE); # endif @@ -85,7 +85,7 @@ #ifdef PERL_OTHERLIBDIRS # define INCPUSH_PERL_OTHERLIBDIRS S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), \ - INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); #endif @@ -106,17 +106,17 @@ # define _INCPUSH_PERL5LIB_ADD _INCPUSH_PERL5LIB_IF incpush_use_sep(perl5lib, 0, INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); #else /* VMS */ - /* Treat PERL5?LIB as a possible search list logical name -- the - * "natural" VMS idiom for a Unix path string. We allow each - * element to be a set of |-separated directories for compatibility. - */ + /* Treat PERL5?LIB as a possible search list logical name -- the + * "natural" VMS idiom for a Unix path string. We allow each + * element to be a set of |-separated directories for compatibility. + */ # define _INCPUSH_PERL5LIB_ADD char buf[256]; \ - int idx = 0; \ - if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) \ - do { \ - incpush_use_sep(buf, 0, \ - INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); \ - } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); + int idx = 0; \ + if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) \ + do { \ + incpush_use_sep(buf, 0, \ + INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); \ + } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); #endif /* this macro is special and use submacros from above */ @@ -127,25 +127,25 @@ */ #ifdef APPLLIB_EXP # define INCPUSH_APPLLIB_OLD_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), \ - INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); #endif #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST) /* Search for version-specific dirs below here */ # define INCPUSH_SITELIB_STEM S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM), \ - INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); #endif #if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST) /* Search for version-specific dirs below here */ # define INCPUSH_PERL_VENDORLIB_STEM S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM), \ - INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); #endif #ifdef PERL_OTHERLIBDIRS # define INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), \ - INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_CAN_RELOCATE); + INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_CAN_RELOCATE); #endif @@ -57,52 +57,52 @@ /* Call the callback or PerlIOBase, and return failure. */ #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \ - if (PerlIOValid(f)) { \ - const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ - if (tab && tab->callback) \ - return (*tab->callback) args; \ - else \ - return PerlIOBase_ ## base args; \ - } \ - else \ - SETERRNO(EBADF, SS_IVCHAN); \ - return failure + if (PerlIOValid(f)) { \ + const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ + if (tab && tab->callback) \ + return (*tab->callback) args; \ + else \ + return PerlIOBase_ ## base args; \ + } \ + else \ + SETERRNO(EBADF, SS_IVCHAN); \ + return failure /* Call the callback or fail, and return failure. */ #define Perl_PerlIO_or_fail(f, callback, failure, args) \ - if (PerlIOValid(f)) { \ - const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ - if (tab && tab->callback) \ - return (*tab->callback) args; \ - SETERRNO(EINVAL, LIB_INVARG); \ - } \ - else \ - SETERRNO(EBADF, SS_IVCHAN); \ - return failure + if (PerlIOValid(f)) { \ + const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ + if (tab && tab->callback) \ + return (*tab->callback) args; \ + SETERRNO(EINVAL, LIB_INVARG); \ + } \ + else \ + SETERRNO(EBADF, SS_IVCHAN); \ + return failure /* Call the callback or PerlIOBase, and be void. */ #define Perl_PerlIO_or_Base_void(f, callback, base, args) \ - if (PerlIOValid(f)) { \ - const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ - if (tab && tab->callback) \ - (*tab->callback) args; \ - else \ - PerlIOBase_ ## base args; \ - } \ - else \ - SETERRNO(EBADF, SS_IVCHAN) + if (PerlIOValid(f)) { \ + const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ + if (tab && tab->callback) \ + (*tab->callback) args; \ + else \ + PerlIOBase_ ## base args; \ + } \ + else \ + SETERRNO(EBADF, SS_IVCHAN) /* Call the callback or fail, and be void. */ #define Perl_PerlIO_or_fail_void(f, callback, args) \ - if (PerlIOValid(f)) { \ - const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ - if (tab && tab->callback) \ - (*tab->callback) args; \ - else \ - SETERRNO(EINVAL, LIB_INVARG); \ - } \ - else \ - SETERRNO(EBADF, SS_IVCHAN) + if (PerlIOValid(f)) { \ + const PerlIO_funcs * const tab = PerlIOBase(f)->tab;\ + if (tab && tab->callback) \ + (*tab->callback) args; \ + else \ + SETERRNO(EINVAL, LIB_INVARG); \ + } \ + else \ + SETERRNO(EBADF, SS_IVCHAN) #if defined(__osf__) && _XOPEN_SOURCE < 500 extern int fseeko(FILE *, off_t, int); @@ -163,42 +163,42 @@ PerlIO_intmode2str(int rawmode, char *mode, int *writing) int ptype; switch (result) { case O_RDONLY: - ptype = IoTYPE_RDONLY; - break; + ptype = IoTYPE_RDONLY; + break; case O_WRONLY: - ptype = IoTYPE_WRONLY; - break; + ptype = IoTYPE_WRONLY; + break; case O_RDWR: default: - ptype = IoTYPE_RDWR; - break; + ptype = IoTYPE_RDWR; + break; } if (writing) - *writing = (result != O_RDONLY); + *writing = (result != O_RDONLY); if (result == O_RDONLY) { - mode[ix++] = 'r'; + mode[ix++] = 'r'; } #ifdef O_APPEND else if (rawmode & O_APPEND) { - mode[ix++] = 'a'; - if (result != O_WRONLY) - mode[ix++] = '+'; + mode[ix++] = 'a'; + if (result != O_WRONLY) + mode[ix++] = '+'; } #endif else { - if (result == O_WRONLY) - mode[ix++] = 'w'; - else { - mode[ix++] = 'r'; - mode[ix++] = '+'; - } + if (result == O_WRONLY) + mode[ix++] = 'w'; + else { + mode[ix++] = 'r'; + mode[ix++] = '+'; + } } #if O_BINARY != 0 /* Unless O_BINARY is different from zero, bit-and:ing * with it won't do much good. */ if (rawmode & O_BINARY) - mode[ix++] = 'b'; + mode[ix++] = 'b'; #endif mode[ix] = '\0'; return ptype; @@ -213,7 +213,7 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) || strEQ(names, ":raw") || strEQ(names, ":bytes") ) { - return 0; + return 0; } Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl", names); /* @@ -245,22 +245,22 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) return win32_fdupopen(f); # else if (f) { - const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f)); - if (fd >= 0) { - char mode[8]; + const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f)); + if (fd >= 0) { + char mode[8]; # ifdef DJGPP - const int omode = djgpp_get_stream_mode(f); + const int omode = djgpp_get_stream_mode(f); # else - const int omode = fcntl(fd, F_GETFL); + const int omode = fcntl(fd, F_GETFL); # endif - PerlIO_intmode2str(omode,mode,NULL); - /* the r+ is a hack */ - return PerlIO_fdopen(fd, mode); - } - return NULL; + PerlIO_intmode2str(omode,mode,NULL); + /* the r+ is a hack */ + return PerlIO_fdopen(fd, mode); + } + return NULL; } else { - SETERRNO(EBADF, SS_IVCHAN); + SETERRNO(EBADF, SS_IVCHAN); } # endif return NULL; @@ -274,35 +274,35 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) PerlIO * PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, - int imode, int perm, PerlIO *old, int narg, SV **args) + int imode, int perm, PerlIO *old, int narg, SV **args) { if (narg) { - if (narg > 1) { - Perl_croak(aTHX_ "More than one argument to open"); - } - if (*args == &PL_sv_undef) - return PerlIO_tmpfile(); - else { + if (narg > 1) { + Perl_croak(aTHX_ "More than one argument to open"); + } + if (*args == &PL_sv_undef) + return PerlIO_tmpfile(); + else { STRLEN len; - const char *name = SvPV_const(*args, len); + const char *name = SvPV_const(*args, len); if (!IS_SAFE_PATHNAME(name, len, "open")) return NULL; - if (*mode == IoTYPE_NUMERIC) { - fd = PerlLIO_open3_cloexec(name, imode, perm); - if (fd >= 0) - return PerlIO_fdopen(fd, mode + 1); - } - else if (old) { - return PerlIO_reopen(name, mode, old); - } - else { - return PerlIO_open(name, mode); - } - } + if (*mode == IoTYPE_NUMERIC) { + fd = PerlLIO_open3_cloexec(name, imode, perm); + if (fd >= 0) + return PerlIO_fdopen(fd, mode + 1); + } + else if (old) { + return PerlIO_reopen(name, mode, old); + } + else { + return PerlIO_open(name, mode); + } + } } else { - return PerlIO_fdopen(fd, (char *) mode); + return PerlIO_fdopen(fd, (char *) mode); } return NULL; } @@ -312,12 +312,12 @@ XS(XS_PerlIO__Layer__find) { dXSARGS; if (items < 2) - Perl_croak(aTHX_ "Usage class->find(name[,load])"); + Perl_croak(aTHX_ "Usage class->find(name[,load])"); else { - const char * const name = SvPV_nolen_const(ST(1)); - ST(0) = (strEQ(name, "crlf") - || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef; - XSRETURN(1); + const char * const name = SvPV_nolen_const(ST(1)); + ST(0) = (strEQ(name, "crlf") + || strEQ(name, "raw")) ? &PL_sv_yes : &PL_sv_undef; + XSRETURN(1); } } @@ -350,27 +350,27 @@ PerlIO_debug(const char *fmt, ...) va_start(ap, fmt); if (!PL_perlio_debug_fd) { - if (!TAINTING_get && - PerlProc_getuid() == PerlProc_geteuid() && - PerlProc_getgid() == PerlProc_getegid()) { - const char * const s = PerlEnv_getenv("PERLIO_DEBUG"); - if (s && *s) - PL_perlio_debug_fd = PerlLIO_open3_cloexec(s, - O_WRONLY | O_CREAT | O_APPEND, 0666); - else - PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ - } else { - /* tainting or set*id, so ignore the environment and send the + if (!TAINTING_get && + PerlProc_getuid() == PerlProc_geteuid() && + PerlProc_getgid() == PerlProc_getegid()) { + const char * const s = PerlEnv_getenv("PERLIO_DEBUG"); + if (s && *s) + PL_perlio_debug_fd = PerlLIO_open3_cloexec(s, + O_WRONLY | O_CREAT | O_APPEND, 0666); + else + PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ + } else { + /* tainting or set*id, so ignore the environment and send the debug output to stderr, like other -D switches. */ - PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ - } + PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ + } } if (PL_perlio_debug_fd > 0) { #ifdef USE_ITHREADS - const char * const s = CopFILE(PL_curcop); - /* Use fixed buffer as sv_catpvf etc. needs SVs */ - char buffer[1024]; - const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop)); + const char * const s = CopFILE(PL_curcop); + /* Use fixed buffer as sv_catpvf etc. needs SVs */ + char buffer[1024]; + const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop)); # ifdef USE_QUADMATH # ifdef HAS_VSNPRINTF /* my_vsnprintf() isn't available with quadmath, but the native vsnprintf() @@ -382,19 +382,19 @@ PerlIO_debug(const char *fmt, ...) STATIC_ASSERT_STMT(0); # endif # else - const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap); + const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap); # endif - PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2)); + PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2)); #else - const char *s = CopFILE(PL_curcop); - STRLEN len; - SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)", - (IV) CopLINE(PL_curcop)); - Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); - - s = SvPV_const(sv, len); - PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len)); - SvREFCNT_dec(sv); + const char *s = CopFILE(PL_curcop); + STRLEN len; + SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)", + (IV) CopLINE(PL_curcop)); + Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); + + s = SvPV_const(sv, len); + PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len)); + SvREFCNT_dec(sv); #endif } va_end(ap); @@ -419,14 +419,14 @@ PerlIO_verify_head(pTHX_ PerlIO *f) PERL_UNUSED_CONTEXT; # endif if (!PerlIOValid(f)) - return; + return; p = head = PerlIOBase(f)->head; assert(p); do { - assert(p->head == head); - if (p == (PerlIOl*)f) - seen = 1; - p = p->next; + assert(p->head == head); + if (p == (PerlIOl*)f) + seen = 1; + p = p->next; } while (p); assert(seen); } @@ -444,7 +444,7 @@ static void PerlIO_init_table(pTHX) { if (PL_perlio) - return; + return; Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl); } @@ -460,17 +460,17 @@ PerlIO_allocate(pTHX) PerlIOl *f; last = &PL_perlio; while ((f = *last)) { - int i; - last = (PerlIOl **) (f); - for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (!((++f)->next)) { - goto good_exit; - } - } + int i; + last = (PerlIOl **) (f); + for (i = 1; i < PERLIO_TABLE_SIZE; i++) { + if (!((++f)->next)) { + goto good_exit; + } + } } Newxz(f,PERLIO_TABLE_SIZE,PerlIOl); if (!f) { - return NULL; + return NULL; } *last = (PerlIOl*) f++; @@ -486,16 +486,16 @@ PerlIO * PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) { if (PerlIOValid(f)) { - const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) ); - if (tab && tab->Dup) - return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags); - else { - return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags); - } + const PerlIO_funcs * const tab = PerlIOBase(f)->tab; + DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) ); + if (tab && tab->Dup) + return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags); + else { + return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags); + } } else - SETERRNO(EBADF, SS_IVCHAN); + SETERRNO(EBADF, SS_IVCHAN); return NULL; } @@ -505,16 +505,16 @@ PerlIO_cleantable(pTHX_ PerlIOl **tablep) { PerlIOl * const table = *tablep; if (table) { - int i; - PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0])); - for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) { - PerlIOl * const f = table + i; - if (f->next) { - PerlIO_close(&(f->next)); - } - } - Safefree(table); - *tablep = NULL; + int i; + PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0])); + for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) { + PerlIOl * const f = table + i; + if (f->next) { + PerlIO_close(&(f->next)); + } + } + Safefree(table); + *tablep = NULL; } } @@ -533,15 +533,15 @@ void PerlIO_list_free(pTHX_ PerlIO_list_t *list) { if (list) { - if (--list->refcnt == 0) { - if (list->array) { - IV i; - for (i = 0; i < list->cur; i++) - SvREFCNT_dec(list->array[i].arg); - Safefree(list->array); - } - Safefree(list); - } + if (--list->refcnt == 0) { + if (list->array) { + IV i; + for (i = 0; i < list->cur; i++) + SvREFCNT_dec(list->array[i].arg); + Safefree(list->array); + } + Safefree(list); + } } } @@ -553,16 +553,16 @@ PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) if (list->cur >= list->len) { const IV new_len = list->len + 8; - if (list->array) - Renew(list->array, new_len, PerlIO_pair_t); - else - Newx(list->array, new_len, PerlIO_pair_t); - list->len = new_len; + if (list->array) + Renew(list->array, new_len, PerlIO_pair_t); + else + Newx(list->array, new_len, PerlIO_pair_t); + list->len = new_len; } p = &(list->array[list->cur++]); p->funcs = funcs; if ((p->arg = arg)) { - SvREFCNT_inc_simple_void_NN(arg); + SvREFCNT_inc_simple_void_NN(arg); } } @@ -571,18 +571,18 @@ PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param) { PerlIO_list_t *list = NULL; if (proto) { - int i; - list = PerlIO_list_alloc(aTHX); - for (i=0; i < proto->cur; i++) { - SV *arg = proto->array[i].arg; + int i; + list = PerlIO_list_alloc(aTHX); + for (i=0; i < proto->cur; i++) { + SV *arg = proto->array[i].arg; #ifdef USE_ITHREADS - if (arg && param) - arg = sv_dup(arg, param); + if (arg && param) + arg = sv_dup(arg, param); #else - PERL_UNUSED_ARG(param); + PERL_UNUSED_ARG(param); #endif - PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg); - } + PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg); + } } return list; } @@ -599,15 +599,15 @@ PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) PerlIO_init_table(aTHX); DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) ); while ((f = *table)) { - int i; - table = (PerlIOl **) (f++); - for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (f->next) { - (void) fp_dup(&(f->next), 0, param); - } - f++; - } - } + int i; + table = (PerlIOl **) (f++); + for (i = 1; i < PERLIO_TABLE_SIZE; i++) { + if (f->next) { + (void) fp_dup(&(f->next), 0, param); + } + f++; + } + } #else PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(proto); @@ -624,23 +624,23 @@ PerlIO_destruct(pTHX) DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) ); #endif while ((f = *table)) { - int i; - table = (PerlIOl **) (f++); - for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - PerlIO *x = &(f->next); - const PerlIOl *l; - while ((l = *x)) { - if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) { - DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) ); - PerlIO_flush(x); - PerlIO_pop(aTHX_ x); - } - else { - x = PerlIONext(x); - } - } - f++; - } + int i; + table = (PerlIOl **) (f++); + for (i = 1; i < PERLIO_TABLE_SIZE; i++) { + PerlIO *x = &(f->next); + const PerlIOl *l; + while ((l = *x)) { + if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) { + DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) ); + PerlIO_flush(x); + PerlIO_pop(aTHX_ x); + } + else { + x = PerlIONext(x); + } + } + f++; + } } } @@ -650,26 +650,26 @@ PerlIO_pop(pTHX_ PerlIO *f) const PerlIOl *l = *f; VERIFY_HEAD(f); if (l) { - DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, + DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab ? l->tab->name : "(Null)") ); - if (l->tab && l->tab->Popped) { - /* - * If popped returns non-zero do not free its layer structure - * it has either done so itself, or it is shared and still in - * use - */ - if ((*l->tab->Popped) (aTHX_ f) != 0) - return; - } - if (PerlIO_lockcnt(f)) { - /* we're in use; defer freeing the structure */ - PerlIOBase(f)->flags = PERLIO_F_CLEARED; - PerlIOBase(f)->tab = NULL; - } - else { - *f = l->next; - Safefree(l); - } + if (l->tab && l->tab->Popped) { + /* + * If popped returns non-zero do not free its layer structure + * it has either done so itself, or it is shared and still in + * use + */ + if ((*l->tab->Popped) (aTHX_ f) != 0) + return; + } + if (PerlIO_lockcnt(f)) { + /* we're in use; defer freeing the structure */ + PerlIOBase(f)->flags = PERLIO_F_CLEARED; + PerlIOBase(f)->tab = NULL; + } + else { + *f = l->next; + Safefree(l); + } } } @@ -686,23 +686,23 @@ PerlIO_get_layers(pTHX_ PerlIO *f) AV * const av = newAV(); if (PerlIOValid(f)) { - PerlIOl *l = PerlIOBase(f); - - while (l) { - /* There is some collusion in the implementation of - XS_PerlIO_get_layers - it knows that name and flags are - generated as fresh SVs here, and takes advantage of that to - "copy" them by taking a reference. If it changes here, it needs - to change there too. */ - SV * const name = l->tab && l->tab->name ? - newSVpv(l->tab->name, 0) : &PL_sv_undef; - SV * const arg = l->tab && l->tab->Getarg ? - (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef; - av_push(av, name); - av_push(av, arg); - av_push(av, newSViv((IV)l->flags)); - l = l->next; - } + PerlIOl *l = PerlIOBase(f); + + while (l) { + /* There is some collusion in the implementation of + XS_PerlIO_get_layers - it knows that name and flags are + generated as fresh SVs here, and takes advantage of that to + "copy" them by taking a reference. If it changes here, it needs + to change there too. */ + SV * const name = l->tab && l->tab->name ? + newSVpv(l->tab->name, 0) : &PL_sv_undef; + SV * const arg = l->tab && l->tab->Getarg ? + (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef; + av_push(av, name); + av_push(av, arg); + av_push(av, newSViv((IV)l->flags)); + l = l->next; + } } return av; @@ -719,38 +719,38 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) IV i; if ((SSize_t) len <= 0) - len = strlen(name); + len = strlen(name); for (i = 0; i < PL_known_layers->cur; i++) { - PerlIO_funcs * const f = PL_known_layers->array[i].funcs; + PerlIO_funcs * const f = PL_known_layers->array[i].funcs; const STRLEN this_len = strlen(f->name); if (this_len == len && memEQ(f->name, name, len)) { - DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) ); - return f; - } + DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) ); + return f; + } } if (load && PL_subname && PL_def_layerlist - && PL_def_layerlist->cur >= 2) { - if (PL_in_load_module) { - Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer"); - return NULL; - } else { - SV * const pkgsv = newSVpvs("PerlIO"); - SV * const layer = newSVpvn(name, len); - CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0); - ENTER; - SAVEBOOL(PL_in_load_module); - if (cv) { - SAVEGENERICSV(PL_warnhook); - PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv))); - } - PL_in_load_module = TRUE; - /* - * The two SVs are magically freed by load_module - */ - Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL); - LEAVE; - return PerlIO_find_layer(aTHX_ name, len, 0); - } + && PL_def_layerlist->cur >= 2) { + if (PL_in_load_module) { + Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer"); + return NULL; + } else { + SV * const pkgsv = newSVpvs("PerlIO"); + SV * const layer = newSVpvn(name, len); + CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0); + ENTER; + SAVEBOOL(PL_in_load_module); + if (cv) { + SAVEGENERICSV(PL_warnhook); + PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv))); + } + PL_in_load_module = TRUE; + /* + * The two SVs are magically freed by load_module + */ + Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL); + LEAVE; + return PerlIO_find_layer(aTHX_ name, len, 0); + } } DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) ); return NULL; @@ -762,11 +762,11 @@ static int perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) { if (SvROK(sv)) { - IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); - PerlIO * const ifp = IoIFP(io); - PerlIO * const ofp = IoOFP(io); - Perl_warn(aTHX_ "set %" SVf " %p %p %p", - SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); + IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); + PerlIO * const ifp = IoIFP(io); + PerlIO * const ofp = IoOFP(io); + Perl_warn(aTHX_ "set %" SVf " %p %p %p", + SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); } return 0; } @@ -775,11 +775,11 @@ static int perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) { if (SvROK(sv)) { - IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); - PerlIO * const ifp = IoIFP(io); - PerlIO * const ofp = IoOFP(io); - Perl_warn(aTHX_ "get %" SVf " %p %p %p", - SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); + IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); + PerlIO * const ifp = IoIFP(io); + PerlIO * const ofp = IoOFP(io); + Perl_warn(aTHX_ "get %" SVf " %p %p %p", + SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); } return 0; } @@ -822,16 +822,16 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) mg_magical(sv); Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv)); for (i = 2; i < items; i++) { - STRLEN len; - const char * const name = SvPV_const(ST(i), len); - SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1); - if (layer) { - av_push(av, SvREFCNT_inc_simple_NN(layer)); - } - else { - ST(count) = ST(i); - count++; - } + STRLEN len; + const char * const name = SvPV_const(ST(i), len); + SV * const layer = PerlIO_find_layer(aTHX_ name, len, 1); + if (layer) { + av_push(av, SvREFCNT_inc_simple_NN(layer)); + } + else { + ST(count) = ST(i); + count++; + } } SvREFCNT_dec(av); XSRETURN(count); @@ -866,16 +866,16 @@ XS(XS_PerlIO__Layer__find) { dXSARGS; if (items < 2) - Perl_croak(aTHX_ "Usage class->find(name[,load])"); + Perl_croak(aTHX_ "Usage class->find(name[,load])"); else { - STRLEN len; - const char * const name = SvPV_const(ST(1), len); - const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0; - PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load); - ST(0) = - (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : - &PL_sv_undef; - XSRETURN(1); + STRLEN len; + const char * const name = SvPV_const(ST(1), len); + const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0; + PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load); + ST(0) = + (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : + &PL_sv_undef; + XSRETURN(1); } } @@ -883,7 +883,7 @@ void PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) { if (!PL_known_layers) - PL_known_layers = PerlIO_list_alloc(aTHX); + PL_known_layers = PerlIO_list_alloc(aTHX); PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL); DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) ); } @@ -892,88 +892,88 @@ int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) { if (names) { - const char *s = names; - while (*s) { - while (isSPACE(*s) || *s == ':') - s++; - if (*s) { - STRLEN llen = 0; - const char *e = s; - const char *as = NULL; - STRLEN alen = 0; - if (!isIDFIRST(*s)) { - /* - * Message is consistent with how attribute lists are - * passed. Even though this means "foo : : bar" is - * seen as an invalid separator character. - */ - const char q = ((*s == '\'') ? '"' : '\''); - Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), - "Invalid separator character %c%c%c in PerlIO layer specification %s", - q, *s, q, s); - SETERRNO(EINVAL, LIB_INVARG); - return -1; - } - do { - e++; - } while (isWORDCHAR(*e)); - llen = e - s; - if (*e == '(') { - int nesting = 1; - as = ++e; - while (nesting) { - switch (*e++) { - case ')': - if (--nesting == 0) - alen = (e - 1) - as; - break; - case '(': - ++nesting; - break; - case '\\': - /* - * It's a nul terminated string, not allowed - * to \ the terminating null. Anything other - * character is passed over. - */ - if (*e++) { - break; - } + const char *s = names; + while (*s) { + while (isSPACE(*s) || *s == ':') + s++; + if (*s) { + STRLEN llen = 0; + const char *e = s; + const char *as = NULL; + STRLEN alen = 0; + if (!isIDFIRST(*s)) { + /* + * Message is consistent with how attribute lists are + * passed. Even though this means "foo : : bar" is + * seen as an invalid separator character. + */ + const char q = ((*s == '\'') ? '"' : '\''); + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), + "Invalid separator character %c%c%c in PerlIO layer specification %s", + q, *s, q, s); + SETERRNO(EINVAL, LIB_INVARG); + return -1; + } + do { + e++; + } while (isWORDCHAR(*e)); + llen = e - s; + if (*e == '(') { + int nesting = 1; + as = ++e; + while (nesting) { + switch (*e++) { + case ')': + if (--nesting == 0) + alen = (e - 1) - as; + break; + case '(': + ++nesting; + break; + case '\\': + /* + * It's a nul terminated string, not allowed + * to \ the terminating null. Anything other + * character is passed over. + */ + if (*e++) { + break; + } /* Fall through */ - case '\0': - e--; - Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), - "Argument list not closed for PerlIO layer \"%.*s\"", - (int) (e - s), s); - return -1; - default: - /* - * boring. - */ - break; - } - } - } - if (e > s) { - PerlIO_funcs * const layer = - PerlIO_find_layer(aTHX_ s, llen, 1); - if (layer) { - SV *arg = NULL; - if (as) - arg = newSVpvn(as, alen); - PerlIO_list_push(aTHX_ av, layer, - (arg) ? arg : &PL_sv_undef); - SvREFCNT_dec(arg); - } - else { - Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", - (int) llen, s); - return -1; - } - } - s = e; - } - } + case '\0': + e--; + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), + "Argument list not closed for PerlIO layer \"%.*s\"", + (int) (e - s), s); + return -1; + default: + /* + * boring. + */ + break; + } + } + } + if (e > s) { + PerlIO_funcs * const layer = + PerlIO_find_layer(aTHX_ s, llen, 1); + if (layer) { + SV *arg = NULL; + if (as) + arg = newSVpvn(as, alen); + PerlIO_list_push(aTHX_ av, layer, + (arg) ? arg : &PL_sv_undef); + SvREFCNT_dec(arg); + } + else { + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", + (int) llen, s); + return -1; + } + } + s = e; + } + } } return 0; } @@ -986,7 +986,7 @@ PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) tab = &PerlIO_crlf; #else if (PerlIO_stdio.Set_ptrcnt) - tab = &PerlIO_stdio; + tab = &PerlIO_stdio; #endif DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) ); PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef); @@ -1002,12 +1002,12 @@ PerlIO_funcs * PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def) { if (n >= 0 && n < av->cur) { - DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n, + DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n, av->array[n].funcs->name) ); - return av->array[n].funcs; + return av->array[n].funcs; } if (!def) - Perl_croak(aTHX_ "panic: PerlIO layer array corrupt"); + Perl_croak(aTHX_ "panic: PerlIO layer array corrupt"); return def; } @@ -1018,9 +1018,9 @@ PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PERL_UNUSED_ARG(arg); PERL_UNUSED_ARG(tab); if (PerlIOValid(f)) { - PerlIO_flush(f); - PerlIO_pop(aTHX_ f); - return 0; + PerlIO_flush(f); + PerlIO_pop(aTHX_ f); + return 0; } return -1; } @@ -1060,34 +1060,34 @@ PerlIO_list_t * PerlIO_default_layers(pTHX) { if (!PL_def_layerlist) { - const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO"); - PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; - PL_def_layerlist = PerlIO_list_alloc(aTHX); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix)); + const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO"); + PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; + PL_def_layerlist = PerlIO_list_alloc(aTHX); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix)); #if defined(WIN32) - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_win32)); # if 0 - osLayer = &PerlIO_win32; + osLayer = &PerlIO_win32; # endif #endif - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove)); - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte)); - PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer, + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_raw)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove)); + PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte)); + PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer, &PL_sv_undef); - if (s) { - PerlIO_parse_layers(aTHX_ PL_def_layerlist, s); - } - else { - PerlIO_default_buffer(aTHX_ PL_def_layerlist); - } + if (s) { + PerlIO_parse_layers(aTHX_ PL_def_layerlist, s); + } + else { + PerlIO_default_buffer(aTHX_ PL_def_layerlist); + } } if (PL_def_layerlist->cur < 2) { - PerlIO_default_buffer(aTHX_ PL_def_layerlist); + PerlIO_default_buffer(aTHX_ PL_def_layerlist); } return PL_def_layerlist; } @@ -1097,7 +1097,7 @@ Perl_boot_core_PerlIO(pTHX) { #ifdef USE_ATTRIBUTES_FOR_PERLIO newXS("io::MODIFY_SCALAR_ATTRIBUTES", XS_io_MODIFY_SCALAR_ATTRIBUTES, - __FILE__); + __FILE__); #endif newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__); newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__); @@ -1108,7 +1108,7 @@ PerlIO_default_layer(pTHX_ I32 n) { PerlIO_list_t * const av = PerlIO_default_layers(aTHX); if (n < 0) - n += av->cur; + n += av->cur; return PerlIO_layer_fetch(aTHX_ av, n, PERLIO_FUNCS_CAST(&PerlIO_stdio)); } @@ -1119,10 +1119,10 @@ void PerlIO_stdstreams(pTHX) { if (!PL_perlio) { - PerlIO_init_table(aTHX); - PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT); - PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT); - PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT); + PerlIO_init_table(aTHX); + PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT); + PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT); + PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT); } } @@ -1131,68 +1131,68 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) { VERIFY_HEAD(f); if (tab->fsize != sizeof(PerlIO_funcs)) { - Perl_croak( aTHX_ - "%s (%" UVuf ") does not match %s (%" UVuf ")", - "PerlIO layer function table size", (UV)tab->fsize, - "size expected by this perl", (UV)sizeof(PerlIO_funcs) ); + Perl_croak( aTHX_ + "%s (%" UVuf ") does not match %s (%" UVuf ")", + "PerlIO layer function table size", (UV)tab->fsize, + "size expected by this perl", (UV)sizeof(PerlIO_funcs) ); } if (tab->size) { - PerlIOl *l; - if (tab->size < sizeof(PerlIOl)) { - Perl_croak( aTHX_ - "%s (%" UVuf ") smaller than %s (%" UVuf ")", - "PerlIO layer instance size", (UV)tab->size, - "size expected by this perl", (UV)sizeof(PerlIOl) ); - } - /* Real layer with a data area */ - if (f) { - char *temp; - Newxz(temp, tab->size, char); - l = (PerlIOl*)temp; - if (l) { - l->next = *f; - l->tab = (PerlIO_funcs*) tab; - l->head = ((PerlIOl*)f)->head; - *f = l; - DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", + PerlIOl *l; + if (tab->size < sizeof(PerlIOl)) { + Perl_croak( aTHX_ + "%s (%" UVuf ") smaller than %s (%" UVuf ")", + "PerlIO layer instance size", (UV)tab->size, + "size expected by this perl", (UV)sizeof(PerlIOl) ); + } + /* Real layer with a data area */ + if (f) { + char *temp; + Newxz(temp, tab->size, char); + l = (PerlIOl*)temp; + if (l) { + l->next = *f; + l->tab = (PerlIO_funcs*) tab; + l->head = ((PerlIOl*)f)->head; + *f = l; + DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, (mode) ? mode : "(Null)", (void*)arg) ); - if (*l->tab->Pushed && - (*l->tab->Pushed) - (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { - PerlIO_pop(aTHX_ f); - return NULL; - } - } - else - return NULL; - } + if (*l->tab->Pushed && + (*l->tab->Pushed) + (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { + PerlIO_pop(aTHX_ f); + return NULL; + } + } + else + return NULL; + } } else if (f) { - /* Pseudo-layer where push does its own stack adjust */ - DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, + /* Pseudo-layer where push does its own stack adjust */ + DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, (mode) ? mode : "(Null)", (void*)arg) ); - if (tab->Pushed && - (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { - return NULL; - } + if (tab->Pushed && + (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { + return NULL; + } } return f; } PerlIO * PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, - IV n, const char *mode, int fd, int imode, int perm, - PerlIO *old, int narg, SV **args) + IV n, const char *mode, int fd, int imode, int perm, + PerlIO *old, int narg, SV **args) { PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0)); if (tab && tab->Open) { - PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args); - if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) { - PerlIO_close(ret); - return NULL; - } - return ret; + PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args); + if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) { + PerlIO_close(ret); + return NULL; + } + return ret; } SETERRNO(EINVAL, LIB_INVARG); return NULL; @@ -1202,16 +1202,16 @@ IV PerlIOBase_binmode(pTHX_ PerlIO *f) { if (PerlIOValid(f)) { - /* Is layer suitable for raw stream ? */ - if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) { - /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */ - PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; - } - else { - /* Not suitable - pop it */ - PerlIO_pop(aTHX_ f); - } - return 0; + /* Is layer suitable for raw stream ? */ + if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) { + /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */ + PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; + } + else { + /* Not suitable - pop it */ + PerlIO_pop(aTHX_ f); + } + return 0; } return -1; } @@ -1224,54 +1224,54 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PERL_UNUSED_ARG(tab); if (PerlIOValid(f)) { - PerlIO *t; - const PerlIOl *l; - PerlIO_flush(f); - /* - * Strip all layers that are not suitable for a raw stream - */ - t = f; - while (t && (l = *t)) { - if (l->tab && l->tab->Binmode) { - /* Has a handler - normal case */ - if ((*l->tab->Binmode)(aTHX_ t) == 0) { - if (*t == l) { - /* Layer still there - move down a layer */ - t = PerlIONext(t); - } - } - else { - return -1; - } - } - else { - /* No handler - pop it */ - PerlIO_pop(aTHX_ t); - } - } - if (PerlIOValid(f)) { - DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f, + PerlIO *t; + const PerlIOl *l; + PerlIO_flush(f); + /* + * Strip all layers that are not suitable for a raw stream + */ + t = f; + while (t && (l = *t)) { + if (l->tab && l->tab->Binmode) { + /* Has a handler - normal case */ + if ((*l->tab->Binmode)(aTHX_ t) == 0) { + if (*t == l) { + /* Layer still there - move down a layer */ + t = PerlIONext(t); + } + } + else { + return -1; + } + } + else { + /* No handler - pop it */ + PerlIO_pop(aTHX_ t); + } + } + if (PerlIOValid(f)) { + DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") ); - return 0; - } + return 0; + } } return -1; } int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, - PerlIO_list_t *layers, IV n, IV max) + PerlIO_list_t *layers, IV n, IV max) { int code = 0; while (n < max) { - PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL); - if (tab) { - if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) { - code = -1; - break; - } - } - n++; + PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL); + if (tab) { + if (!PerlIO_push(aTHX_ f, tab, mode, PerlIOArg)) { + code = -1; + break; + } + } + n++; } return code; } @@ -1283,12 +1283,12 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) ENTER; save_scalar(PL_errgv); if (f && names) { - PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX); - code = PerlIO_parse_layers(aTHX_ layers, names); - if (code == 0) { - code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur); - } - PerlIO_list_free(aTHX_ layers); + PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX); + code = PerlIO_parse_layers(aTHX_ layers, names); + if (code == 0) { + code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur); + } + PerlIO_list_free(aTHX_ layers); } LEAVE; return code; @@ -1313,53 +1313,53 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) iotype, mode, (names) ? names : "(Null)") ); if (names) { - /* Do not flush etc. if (e.g.) switching encodings. - if a pushed layer knows it needs to flush lower layers - (for example :unix which is never going to call them) - it can do the flush when it is pushed. - */ - return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0); + /* Do not flush etc. if (e.g.) switching encodings. + if a pushed layer knows it needs to flush lower layers + (for example :unix which is never going to call them) + it can do the flush when it is pushed. + */ + return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0); } else { - /* Fake 5.6 legacy of using this call to turn ON O_TEXT */ + /* Fake 5.6 legacy of using this call to turn ON O_TEXT */ #ifdef PERLIO_USING_CRLF - /* Legacy binmode only has meaning if O_TEXT has a value distinct from - O_BINARY so we can look for it in mode. - */ - if (!(mode & O_BINARY)) { - /* Text mode */ - /* FIXME?: Looking down the layer stack seems wrong, - but is a way of reaching past (say) an encoding layer - to flip CRLF-ness of the layer(s) below - */ - while (*f) { - /* Perhaps we should turn on bottom-most aware layer - e.g. Ilya's idea that UNIX TTY could serve - */ - if (PerlIOBase(f)->tab && - PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) - { - if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) { - /* Not in text mode - flush any pending stuff and flip it */ - PerlIO_flush(f); - PerlIOBase(f)->flags |= PERLIO_F_CRLF; - } - /* Only need to turn it on in one layer so we are done */ - return TRUE; - } - f = PerlIONext(f); - } - /* Not finding a CRLF aware layer presumably means we are binary - which is not what was requested - so we failed - We _could_ push :crlf layer but so could caller - */ - return FALSE; - } + /* Legacy binmode only has meaning if O_TEXT has a value distinct from + O_BINARY so we can look for it in mode. + */ + if (!(mode & O_BINARY)) { + /* Text mode */ + /* FIXME?: Looking down the layer stack seems wrong, + but is a way of reaching past (say) an encoding layer + to flip CRLF-ness of the layer(s) below + */ + while (*f) { + /* Perhaps we should turn on bottom-most aware layer + e.g. Ilya's idea that UNIX TTY could serve + */ + if (PerlIOBase(f)->tab && + PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) + { + if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) { + /* Not in text mode - flush any pending stuff and flip it */ + PerlIO_flush(f); + PerlIOBase(f)->flags |= PERLIO_F_CRLF; + } + /* Only need to turn it on in one layer so we are done */ + return TRUE; + } + f = PerlIONext(f); + } + /* Not finding a CRLF aware layer presumably means we are binary + which is not what was requested - so we failed + We _could_ push :crlf layer but so could caller + */ + return FALSE; + } #endif - /* Legacy binmode is now _defined_ as being equivalent to pushing :raw - So code that used to be here is now in PerlIORaw_pushed(). - */ - return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL)); + /* Legacy binmode is now _defined_ as being equivalent to pushing :raw + So code that used to be here is now in PerlIORaw_pushed(). + */ + return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL)); } } @@ -1367,15 +1367,15 @@ int PerlIO__close(pTHX_ PerlIO *f) { if (PerlIOValid(f)) { - PerlIO_funcs * const tab = PerlIOBase(f)->tab; - if (tab && tab->Close) - return (*tab->Close)(aTHX_ f); - else - return PerlIOBase_close(aTHX_ f); + PerlIO_funcs * const tab = PerlIOBase(f)->tab; + if (tab && tab->Close) + return (*tab->Close)(aTHX_ f); + else + return PerlIOBase_close(aTHX_ f); } else { - SETERRNO(EBADF, SS_IVCHAN); - return -1; + SETERRNO(EBADF, SS_IVCHAN); + return -1; } } @@ -1384,10 +1384,10 @@ Perl_PerlIO_close(pTHX_ PerlIO *f) { const int code = PerlIO__close(aTHX_ f); while (PerlIOValid(f)) { - PerlIO_pop(aTHX_ f); - if (PerlIO_lockcnt(f)) - /* we're in use; the 'pop' deferred freeing the structure */ - f = PerlIONext(f); + PerlIO_pop(aTHX_ f); + if (PerlIO_lockcnt(f)) + /* we're in use; the 'pop' deferred freeing the structure */ + f = PerlIONext(f); } return code; } @@ -1406,13 +1406,13 @@ PerlIO_layer_from_ref(pTHX_ SV *sv) * For any scalar type load the handler which is bundled with perl */ if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) { - PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1); - /* This isn't supposed to happen, since PerlIO::scalar is core, - * but could happen anyway in smaller installs or with PAR */ - if (!f) - /* diag_listed_as: Unknown PerlIO layer "%s" */ - Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); - return f; + PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1); + /* This isn't supposed to happen, since PerlIO::scalar is core, + * but could happen anyway in smaller installs or with PAR */ + if (!f) + /* diag_listed_as: Unknown PerlIO layer "%s" */ + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); + return f; } /* @@ -1420,156 +1420,156 @@ PerlIO_layer_from_ref(pTHX_ SV *sv) */ switch (SvTYPE(sv)) { case SVt_PVAV: - return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0); + return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0); case SVt_PVHV: - return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0); + return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0); case SVt_PVCV: - return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0); + return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0); case SVt_PVGV: - return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0); + return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0); default: - return NULL; + return NULL; } } PerlIO_list_t * PerlIO_resolve_layers(pTHX_ const char *layers, - const char *mode, int narg, SV **args) + const char *mode, int narg, SV **args) { PerlIO_list_t *def = PerlIO_default_layers(aTHX); int incdef = 1; if (!PL_perlio) - PerlIO_stdstreams(aTHX); + PerlIO_stdstreams(aTHX); if (narg) { - SV * const arg = *args; - /* - * If it is a reference but not an object see if we have a handler - * for it - */ - if (SvROK(arg) && !SvOBJECT(SvRV(arg))) { - PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); - if (handler) { - def = PerlIO_list_alloc(aTHX); - PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef); - incdef = 0; - } - /* - * Don't fail if handler cannot be found :via(...) etc. may do - * something sensible else we will just stringfy and open - * resulting string. - */ - } + SV * const arg = *args; + /* + * If it is a reference but not an object see if we have a handler + * for it + */ + if (SvROK(arg) && !SvOBJECT(SvRV(arg))) { + PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); + if (handler) { + def = PerlIO_list_alloc(aTHX); + PerlIO_list_push(aTHX_ def, handler, &PL_sv_undef); + incdef = 0; + } + /* + * Don't fail if handler cannot be found :via(...) etc. may do + * something sensible else we will just stringfy and open + * resulting string. + */ + } } if (!layers || !*layers) - layers = Perl_PerlIO_context_layers(aTHX_ mode); + layers = Perl_PerlIO_context_layers(aTHX_ mode); if (layers && *layers) { - PerlIO_list_t *av; - if (incdef) { - av = PerlIO_clone_list(aTHX_ def, NULL); - } - else { - av = def; - } - if (PerlIO_parse_layers(aTHX_ av, layers) == 0) { - return av; - } - else { - PerlIO_list_free(aTHX_ av); - return NULL; - } + PerlIO_list_t *av; + if (incdef) { + av = PerlIO_clone_list(aTHX_ def, NULL); + } + else { + av = def; + } + if (PerlIO_parse_layers(aTHX_ av, layers) == 0) { + return av; + } + else { + PerlIO_list_free(aTHX_ av); + return NULL; + } } else { - if (incdef) - def->refcnt++; - return def; + if (incdef) + def->refcnt++; + return def; } } PerlIO * PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, - int imode, int perm, PerlIO *f, int narg, SV **args) + int imode, int perm, PerlIO *f, int narg, SV **args) { if (!f && narg == 1 && *args == &PL_sv_undef) { imode = PerlIOUnix_oflags(mode); - if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) { - if (!layers || !*layers) - layers = Perl_PerlIO_context_layers(aTHX_ mode); - if (layers && *layers) - PerlIO_apply_layers(aTHX_ f, mode, layers); - } + if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) { + if (!layers || !*layers) + layers = Perl_PerlIO_context_layers(aTHX_ mode); + if (layers && *layers) + PerlIO_apply_layers(aTHX_ f, mode, layers); + } } else { - PerlIO_list_t *layera; - IV n; - PerlIO_funcs *tab = NULL; - if (PerlIOValid(f)) { - /* - * This is "reopen" - it is not tested as perl does not use it - * yet - */ - PerlIOl *l = *f; - layera = PerlIO_list_alloc(aTHX); - while (l) { - SV *arg = NULL; - if (l->tab && l->tab->Getarg) - arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0); - PerlIO_list_push(aTHX_ layera, l->tab, - (arg) ? arg : &PL_sv_undef); - SvREFCNT_dec(arg); - l = *PerlIONext(&l); - } - } - else { - layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); - if (!layera) { - return NULL; - } - } - /* - * Start at "top" of layer stack - */ - n = layera->cur - 1; - while (n >= 0) { - PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL); - if (t && t->Open) { - tab = t; - break; - } - n--; - } - if (tab) { - /* - * Found that layer 'n' can do opens - call it - */ - if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) { - Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name); - } - DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", + PerlIO_list_t *layera; + IV n; + PerlIO_funcs *tab = NULL; + if (PerlIOValid(f)) { + /* + * This is "reopen" - it is not tested as perl does not use it + * yet + */ + PerlIOl *l = *f; + layera = PerlIO_list_alloc(aTHX); + while (l) { + SV *arg = NULL; + if (l->tab && l->tab->Getarg) + arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0); + PerlIO_list_push(aTHX_ layera, l->tab, + (arg) ? arg : &PL_sv_undef); + SvREFCNT_dec(arg); + l = *PerlIONext(&l); + } + } + else { + layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); + if (!layera) { + return NULL; + } + } + /* + * Start at "top" of layer stack + */ + n = layera->cur - 1; + while (n >= 0) { + PerlIO_funcs * const t = PerlIO_layer_fetch(aTHX_ layera, n, NULL); + if (t && t->Open) { + tab = t; + break; + } + n--; + } + if (tab) { + /* + * Found that layer 'n' can do opens - call it + */ + if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) { + Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name); + } + DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", tab->name, layers ? layers : "(Null)", mode, fd, imode, perm, (void*)f, narg, (void*)args) ); - if (tab->Open) - f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm, - f, narg, args); - else { - SETERRNO(EINVAL, LIB_INVARG); - f = NULL; - } - if (f) { - if (n + 1 < layera->cur) { - /* - * More layers above the one that we used to open - - * apply them now - */ - if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) { - /* If pushing layers fails close the file */ - PerlIO_close(f); - f = NULL; - } - } - } - } - PerlIO_list_free(aTHX_ layera); + if (tab->Open) + f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm, + f, narg, args); + else { + SETERRNO(EINVAL, LIB_INVARG); + f = NULL; + } + if (f) { + if (n + 1 < layera->cur) { + /* + * More layers above the one that we used to open - + * apply them now + */ + if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) { + /* If pushing layers fails close the file */ + PerlIO_close(f); + f = NULL; + } + } + } + } + PerlIO_list_free(aTHX_ layera); } return f; } @@ -1615,41 +1615,41 @@ int Perl_PerlIO_flush(pTHX_ PerlIO *f) { if (f) { - if (*f) { - const PerlIO_funcs *tab = PerlIOBase(f)->tab; - - if (tab && tab->Flush) - return (*tab->Flush) (aTHX_ f); - else - return 0; /* If no Flush defined, silently succeed. */ - } - else { - DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) ); - SETERRNO(EBADF, SS_IVCHAN); - return -1; - } + if (*f) { + const PerlIO_funcs *tab = PerlIOBase(f)->tab; + + if (tab && tab->Flush) + return (*tab->Flush) (aTHX_ f); + else + return 0; /* If no Flush defined, silently succeed. */ + } + else { + DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) ); + SETERRNO(EBADF, SS_IVCHAN); + return -1; + } } else { - /* - * Is it good API design to do flush-all on NULL, a potentially - * erroneous input? Maybe some magical value (PerlIO* - * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar - * things on fflush(NULL), but should we be bound by their design - * decisions? --jhi - */ - PerlIOl **table = &PL_perlio; - PerlIOl *ff; - int code = 0; - while ((ff = *table)) { - int i; - table = (PerlIOl **) (ff++); - for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (ff->next && PerlIO_flush(&(ff->next)) != 0) - code = -1; - ff++; - } - } - return code; + /* + * Is it good API design to do flush-all on NULL, a potentially + * erroneous input? Maybe some magical value (PerlIO* + * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar + * things on fflush(NULL), but should we be bound by their design + * decisions? --jhi + */ + PerlIOl **table = &PL_perlio; + PerlIOl *ff; + int code = 0; + while ((ff = *table)) { + int i; + table = (PerlIOl **) (ff++); + for (i = 1; i < PERLIO_TABLE_SIZE; i++) { + if (ff->next && PerlIO_flush(&(ff->next)) != 0) + code = -1; + ff++; + } + } + return code; } } @@ -1659,16 +1659,16 @@ PerlIOBase_flush_linebuf(pTHX) PerlIOl **table = &PL_perlio; PerlIOl *f; while ((f = *table)) { - int i; - table = (PerlIOl **) (f++); - for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (f->next - && (PerlIOBase(&(f->next))-> - flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) - == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) - PerlIO_flush(&(f->next)); - f++; - } + int i; + table = (PerlIOl **) (f++); + for (i = 1; i < PERLIO_TABLE_SIZE; i++) { + if (f->next + && (PerlIOBase(&(f->next))-> + flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) + == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) + PerlIO_flush(&(f->next)); + f++; + } } } @@ -1682,9 +1682,9 @@ int PerlIO_isutf8(PerlIO *f) { if (PerlIOValid(f)) - return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; + return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; else - SETERRNO(EBADF, SS_IVCHAN); + SETERRNO(EBADF, SS_IVCHAN); return -1; } @@ -1717,10 +1717,10 @@ int PerlIO_has_base(PerlIO *f) { if (PerlIOValid(f)) { - const PerlIO_funcs * const tab = PerlIOBase(f)->tab; + const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - if (tab) - return (tab->Get_base != NULL); + if (tab) + return (tab->Get_base != NULL); } return 0; @@ -1730,12 +1730,12 @@ int PerlIO_fast_gets(PerlIO *f) { if (PerlIOValid(f)) { - if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) { - const PerlIO_funcs * const tab = PerlIOBase(f)->tab; + if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) { + const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - if (tab) - return (tab->Set_ptrcnt != NULL); - } + if (tab) + return (tab->Set_ptrcnt != NULL); + } } return 0; @@ -1745,10 +1745,10 @@ int PerlIO_has_cntptr(PerlIO *f) { if (PerlIOValid(f)) { - const PerlIO_funcs * const tab = PerlIOBase(f)->tab; + const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - if (tab) - return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); + if (tab) + return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); } return 0; @@ -1758,10 +1758,10 @@ int PerlIO_canset_cnt(PerlIO *f) { if (PerlIOValid(f)) { - const PerlIO_funcs * const tab = PerlIOBase(f)->tab; + const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - if (tab) - return (tab->Set_ptrcnt != NULL); + if (tab) + return (tab->Set_ptrcnt != NULL); } return 0; @@ -1817,11 +1817,11 @@ PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PERL_UNUSED_ARG(mode); PERL_UNUSED_ARG(arg); if (PerlIOValid(f)) { - if (tab && tab->kind & PERLIO_K_UTF8) - PerlIOBase(f)->flags |= PERLIO_F_UTF8; - else - PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; - return 0; + if (tab && tab->kind & PERLIO_K_UTF8) + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + else + PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; + return 0; } return -1; } @@ -1935,27 +1935,27 @@ PerlIO_modestr(PerlIO * f, char *buf) { char *s = buf; if (PerlIOValid(f)) { - const IV flags = PerlIOBase(f)->flags; - if (flags & PERLIO_F_APPEND) { - *s++ = 'a'; - if (flags & PERLIO_F_CANREAD) { - *s++ = '+'; - } - } - else if (flags & PERLIO_F_CANREAD) { - *s++ = 'r'; - if (flags & PERLIO_F_CANWRITE) - *s++ = '+'; - } - else if (flags & PERLIO_F_CANWRITE) { - *s++ = 'w'; - if (flags & PERLIO_F_CANREAD) { - *s++ = '+'; - } - } + const IV flags = PerlIOBase(f)->flags; + if (flags & PERLIO_F_APPEND) { + *s++ = 'a'; + if (flags & PERLIO_F_CANREAD) { + *s++ = '+'; + } + } + else if (flags & PERLIO_F_CANREAD) { + *s++ = 'r'; + if (flags & PERLIO_F_CANWRITE) + *s++ = '+'; + } + else if (flags & PERLIO_F_CANWRITE) { + *s++ = 'w'; + if (flags & PERLIO_F_CANREAD) { + *s++ = '+'; + } + } #ifdef PERLIO_USING_CRLF - if (!(flags & PERLIO_F_CRLF)) - *s++ = 'b'; + if (!(flags & PERLIO_F_CRLF)) + *s++ = 'b'; #endif } *s = '\0'; @@ -1971,87 +1971,87 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PERL_UNUSED_ARG(arg); l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | - PERLIO_F_TRUNCATE | PERLIO_F_APPEND); + PERLIO_F_TRUNCATE | PERLIO_F_APPEND); if (tab && tab->Set_ptrcnt != NULL) - l->flags |= PERLIO_F_FASTGETS; + l->flags |= PERLIO_F_FASTGETS; if (mode) { - if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT) - mode++; - switch (*mode++) { - case 'r': - l->flags |= PERLIO_F_CANREAD; - break; - case 'a': - l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE; - break; - case 'w': - l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE; - break; - default: - SETERRNO(EINVAL, LIB_INVARG); - return -1; - } + if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT) + mode++; + switch (*mode++) { + case 'r': + l->flags |= PERLIO_F_CANREAD; + break; + case 'a': + l->flags |= PERLIO_F_APPEND | PERLIO_F_CANWRITE; + break; + case 'w': + l->flags |= PERLIO_F_TRUNCATE | PERLIO_F_CANWRITE; + break; + default: + SETERRNO(EINVAL, LIB_INVARG); + return -1; + } #ifdef EBCDIC - { + { /* The mode variable contains one positional parameter followed by * optional keyword parameters. The positional parameters must be * passed as lowercase characters. The keyword parameters can be * passed in mixed case. They must be separated by commas. Only one * instance of a keyword can be specified. */ - int comma = 0; - while (*mode) { - switch (*mode++) { - case '+': - if(!comma) - l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; - break; - case 'b': - if(!comma) - l->flags &= ~PERLIO_F_CRLF; - break; - case 't': - if(!comma) - l->flags |= PERLIO_F_CRLF; - break; - case ',': - comma = 1; - break; - default: - break; - } - } - } + int comma = 0; + while (*mode) { + switch (*mode++) { + case '+': + if(!comma) + l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; + break; + case 'b': + if(!comma) + l->flags &= ~PERLIO_F_CRLF; + break; + case 't': + if(!comma) + l->flags |= PERLIO_F_CRLF; + break; + case ',': + comma = 1; + break; + default: + break; + } + } + } #else - while (*mode) { - switch (*mode++) { - case '+': - l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; - break; - case 'b': - l->flags &= ~PERLIO_F_CRLF; - break; - case 't': - l->flags |= PERLIO_F_CRLF; - break; - default: - SETERRNO(EINVAL, LIB_INVARG); - return -1; - } - } + while (*mode) { + switch (*mode++) { + case '+': + l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; + break; + case 'b': + l->flags &= ~PERLIO_F_CRLF; + break; + case 't': + l->flags |= PERLIO_F_CRLF; + break; + default: + SETERRNO(EINVAL, LIB_INVARG); + return -1; + } + } #endif } else { - if (l->next) { - l->flags |= l->next->flags & - (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE | - PERLIO_F_APPEND); - } + if (l->next) { + l->flags |= l->next->flags & + (PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE | + PERLIO_F_APPEND); + } } #if 0 DEBUG_i( PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n", - (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", - l->flags, PerlIO_modestr(f, temp)); + (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", + l->flags, PerlIO_modestr(f, temp)); ); #endif return 0; @@ -2083,34 +2083,34 @@ PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) STDCHAR *buf = (STDCHAR *) vbuf; if (f) { if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) { - PerlIOBase(f)->flags |= PERLIO_F_ERROR; - SETERRNO(EBADF, SS_IVCHAN); - PerlIO_save_errno(f); - return 0; - } - while (count > 0) { - get_cnt: - { - SSize_t avail = PerlIO_get_cnt(f); - SSize_t take = 0; - if (avail > 0) - take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail; - if (take > 0) { - STDCHAR *ptr = PerlIO_get_ptr(f); - Copy(ptr, buf, take, STDCHAR); - PerlIO_set_ptrcnt(f, ptr + take, (avail -= take)); - count -= take; - buf += take; - if (avail == 0) /* set_ptrcnt could have reset avail */ - goto get_cnt; - } - if (count > 0 && avail <= 0) { - if (PerlIO_fill(f) != 0) - break; - } - } - } - return (buf - (STDCHAR *) vbuf); + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + SETERRNO(EBADF, SS_IVCHAN); + PerlIO_save_errno(f); + return 0; + } + while (count > 0) { + get_cnt: + { + SSize_t avail = PerlIO_get_cnt(f); + SSize_t take = 0; + if (avail > 0) + take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail; + if (take > 0) { + STDCHAR *ptr = PerlIO_get_ptr(f); + Copy(ptr, buf, take, STDCHAR); + PerlIO_set_ptrcnt(f, ptr + take, (avail -= take)); + count -= take; + buf += take; + if (avail == 0) /* set_ptrcnt could have reset avail */ + goto get_cnt; + } + if (count > 0 && avail <= 0) { + if (PerlIO_fill(f) != 0) + break; + } + } + } + return (buf - (STDCHAR *) vbuf); } return 0; } @@ -2136,26 +2136,26 @@ PerlIOBase_close(pTHX_ PerlIO *f) { IV code = -1; if (PerlIOValid(f)) { - PerlIO *n = PerlIONext(f); - code = PerlIO_flush(f); - PerlIOBase(f)->flags &= - ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); - while (PerlIOValid(n)) { - const PerlIO_funcs * const tab = PerlIOBase(n)->tab; - if (tab && tab->Close) { - if ((*tab->Close)(aTHX_ n) != 0) - code = -1; - break; - } - else { - PerlIOBase(n)->flags &= - ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); - } - n = PerlIONext(n); - } + PerlIO *n = PerlIONext(f); + code = PerlIO_flush(f); + PerlIOBase(f)->flags &= + ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); + while (PerlIOValid(n)) { + const PerlIO_funcs * const tab = PerlIOBase(n)->tab; + if (tab && tab->Close) { + if ((*tab->Close)(aTHX_ n) != 0) + code = -1; + break; + } + else { + PerlIOBase(n)->flags &= + ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); + } + n = PerlIONext(n); + } } else { - SETERRNO(EBADF, SS_IVCHAN); + SETERRNO(EBADF, SS_IVCHAN); } return code; } @@ -2165,7 +2165,7 @@ PerlIOBase_eof(pTHX_ PerlIO *f) { PERL_UNUSED_CONTEXT; if (PerlIOValid(f)) { - return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0; + return (PerlIOBase(f)->flags & PERLIO_F_EOF) != 0; } return 1; } @@ -2175,7 +2175,7 @@ PerlIOBase_error(pTHX_ PerlIO *f) { PERL_UNUSED_CONTEXT; if (PerlIOValid(f)) { - return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0; + return (PerlIOBase(f)->flags & PERLIO_F_ERROR) != 0; } return 1; } @@ -2184,10 +2184,10 @@ void PerlIOBase_clearerr(pTHX_ PerlIO *f) { if (PerlIOValid(f)) { - PerlIO * const n = PerlIONext(f); - PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF); - if (PerlIOValid(n)) - PerlIO_clearerr(n); + PerlIO * const n = PerlIONext(f); + PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR | PERLIO_F_EOF); + if (PerlIOValid(n)) + PerlIO_clearerr(n); } } @@ -2196,7 +2196,7 @@ PerlIOBase_setlinebuf(pTHX_ PerlIO *f) { PERL_UNUSED_CONTEXT; if (PerlIOValid(f)) { - PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; + PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; } } @@ -2204,15 +2204,15 @@ SV * PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param) { if (!arg) - return NULL; + return NULL; #ifdef USE_ITHREADS if (param) { - arg = sv_dup(arg, param); - SvREFCNT_inc_simple_void_NN(arg); - return arg; + arg = sv_dup(arg, param); + SvREFCNT_inc_simple_void_NN(arg); + return arg; } else { - return newSVsv(arg); + return newSVsv(arg); } #else PERL_UNUSED_ARG(param); @@ -2225,26 +2225,26 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) { PerlIO * const nexto = PerlIONext(o); if (PerlIOValid(nexto)) { - const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab; - if (tab && tab->Dup) - f = (*tab->Dup)(aTHX_ f, nexto, param, flags); - else - f = PerlIOBase_dup(aTHX_ f, nexto, param, flags); + const PerlIO_funcs * const tab = PerlIOBase(nexto)->tab; + if (tab && tab->Dup) + f = (*tab->Dup)(aTHX_ f, nexto, param, flags); + else + f = PerlIOBase_dup(aTHX_ f, nexto, param, flags); } if (f) { - PerlIO_funcs * const self = PerlIOBase(o)->tab; - SV *arg = NULL; - char buf[8]; - assert(self); - DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", + PerlIO_funcs * const self = PerlIOBase(o)->tab; + SV *arg = NULL; + char buf[8]; + assert(self); + DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", self->name, (void*)f, (void*)o, (void*)param) ); - if (self->Getarg) - arg = (*self->Getarg)(aTHX_ o, param, flags); - f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); - if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8) - PerlIOBase(f)->flags |= PERLIO_F_UTF8; - SvREFCNT_dec(arg); + if (self->Getarg) + arg = (*self->Getarg)(aTHX_ o, param, flags); + f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); + if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8) + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + SvREFCNT_dec(arg); } return f; } @@ -2268,7 +2268,7 @@ S_more_refcounted_fds(pTHX_ const int new_fd) old_max, new_fd, new_max) ); if (new_fd < old_max) { - return; + return; } assert (new_max > new_fd); @@ -2278,8 +2278,8 @@ S_more_refcounted_fds(pTHX_ const int new_fd) new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int)); if (!new_array) { - MUTEX_UNLOCK(&PL_perlio_mutex); - croak_no_mem(); + MUTEX_UNLOCK(&PL_perlio_mutex); + croak_no_mem(); } PL_perlio_fd_refcnt_size = new_max; @@ -2306,23 +2306,23 @@ PerlIOUnix_refcnt_inc(int fd) dTHX; if (fd >= 0) { - MUTEX_LOCK(&PL_perlio_mutex); - if (fd >= PL_perlio_fd_refcnt_size) - S_more_refcounted_fds(aTHX_ fd); - - PL_perlio_fd_refcnt[fd]++; - if (PL_perlio_fd_refcnt[fd] <= 0) { - /* diag_listed_as: refcnt_inc: fd %d%s */ - Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n", - fd, PL_perlio_fd_refcnt[fd]); - } - DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n", + MUTEX_LOCK(&PL_perlio_mutex); + if (fd >= PL_perlio_fd_refcnt_size) + S_more_refcounted_fds(aTHX_ fd); + + PL_perlio_fd_refcnt[fd]++; + if (PL_perlio_fd_refcnt[fd] <= 0) { + /* diag_listed_as: refcnt_inc: fd %d%s */ + Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n", + fd, PL_perlio_fd_refcnt[fd]); + } + DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n", fd, PL_perlio_fd_refcnt[fd]) ); - MUTEX_UNLOCK(&PL_perlio_mutex); + MUTEX_UNLOCK(&PL_perlio_mutex); } else { - /* diag_listed_as: refcnt_inc: fd %d%s */ - Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd); + /* diag_listed_as: refcnt_inc: fd %d%s */ + Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd); } } @@ -2334,23 +2334,23 @@ PerlIOUnix_refcnt_dec(int fd) #ifdef DEBUGGING dTHX; #endif - MUTEX_LOCK(&PL_perlio_mutex); - if (fd >= PL_perlio_fd_refcnt_size) { - /* diag_listed_as: refcnt_dec: fd %d%s */ - Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n", - fd, PL_perlio_fd_refcnt_size); - } - if (PL_perlio_fd_refcnt[fd] <= 0) { - /* diag_listed_as: refcnt_dec: fd %d%s */ - Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n", - fd, PL_perlio_fd_refcnt[fd]); - } - cnt = --PL_perlio_fd_refcnt[fd]; - DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) ); - MUTEX_UNLOCK(&PL_perlio_mutex); + MUTEX_LOCK(&PL_perlio_mutex); + if (fd >= PL_perlio_fd_refcnt_size) { + /* diag_listed_as: refcnt_dec: fd %d%s */ + Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n", + fd, PL_perlio_fd_refcnt_size); + } + if (PL_perlio_fd_refcnt[fd] <= 0) { + /* diag_listed_as: refcnt_dec: fd %d%s */ + Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n", + fd, PL_perlio_fd_refcnt[fd]); + } + cnt = --PL_perlio_fd_refcnt[fd]; + DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) ); + MUTEX_UNLOCK(&PL_perlio_mutex); } else { - /* diag_listed_as: refcnt_dec: fd %d%s */ - Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd); + /* diag_listed_as: refcnt_dec: fd %d%s */ + Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd); } return cnt; } @@ -2361,22 +2361,22 @@ PerlIOUnix_refcnt(int fd) dTHX; int cnt = 0; if (fd >= 0) { - MUTEX_LOCK(&PL_perlio_mutex); - if (fd >= PL_perlio_fd_refcnt_size) { - /* diag_listed_as: refcnt: fd %d%s */ - Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n", - fd, PL_perlio_fd_refcnt_size); - } - if (PL_perlio_fd_refcnt[fd] <= 0) { - /* diag_listed_as: refcnt: fd %d%s */ - Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n", - fd, PL_perlio_fd_refcnt[fd]); - } - cnt = PL_perlio_fd_refcnt[fd]; - MUTEX_UNLOCK(&PL_perlio_mutex); + MUTEX_LOCK(&PL_perlio_mutex); + if (fd >= PL_perlio_fd_refcnt_size) { + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n", + fd, PL_perlio_fd_refcnt_size); + } + if (PL_perlio_fd_refcnt[fd] <= 0) { + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n", + fd, PL_perlio_fd_refcnt[fd]); + } + cnt = PL_perlio_fd_refcnt[fd]; + MUTEX_UNLOCK(&PL_perlio_mutex); } else { - /* diag_listed_as: refcnt: fd %d%s */ - Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd); + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd); } return cnt; } @@ -2393,19 +2393,19 @@ PerlIO_cleanup(pTHX) /* Raise STDIN..STDERR refcount so we don't close them */ for (i=0; i < 3; i++) - PerlIOUnix_refcnt_inc(i); + PerlIOUnix_refcnt_inc(i); PerlIO_cleantable(aTHX_ &PL_perlio); /* Restore STDIN..STDERR refcount */ for (i=0; i < 3; i++) - PerlIOUnix_refcnt_dec(i); + PerlIOUnix_refcnt_dec(i); if (PL_known_layers) { - PerlIO_list_free(aTHX_ PL_known_layers); - PL_known_layers = NULL; + PerlIO_list_free(aTHX_ PL_known_layers); + PL_known_layers = NULL; } if (PL_def_layerlist) { - PerlIO_list_free(aTHX_ PL_def_layerlist); - PL_def_layerlist = NULL; + PerlIO_list_free(aTHX_ PL_def_layerlist); + PL_def_layerlist = NULL; } } @@ -2419,22 +2419,22 @@ void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */ */ # ifdef DEBUGGING { - /* By now all filehandles should have been closed, so any - * stray (non-STD-)filehandles indicate *possible* (PerlIO) - * errors. */ + /* By now all filehandles should have been closed, so any + * stray (non-STD-)filehandles indicate *possible* (PerlIO) + * errors. */ #define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64 #define PERLIO_TEARDOWN_MESSAGE_FD 2 - char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE]; - int i; - for (i = 3; i < PL_perlio_fd_refcnt_size; i++) { - if (PL_perlio_fd_refcnt[i]) { - const STRLEN len = - my_snprintf(buf, sizeof(buf), - "PerlIO_teardown: fd %d refcnt=%d\n", - i, PL_perlio_fd_refcnt[i]); - PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len); - } - } + char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE]; + int i; + for (i = 3; i < PL_perlio_fd_refcnt_size; i++) { + if (PL_perlio_fd_refcnt[i]) { + const STRLEN len = + my_snprintf(buf, sizeof(buf), + "PerlIO_teardown: fd %d refcnt=%d\n", + i, PL_perlio_fd_refcnt[i]); + PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len); + } + } } # endif #endif @@ -2442,9 +2442,9 @@ void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */ * all the interpreters are gone. */ if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */ && PL_perlio_fd_refcnt) { - free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */ - PL_perlio_fd_refcnt = NULL; - PL_perlio_fd_refcnt_size = 0; + free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */ + PL_perlio_fd_refcnt = NULL; + PL_perlio_fd_refcnt_size = 0; } } @@ -2479,19 +2479,19 @@ S_perlio_async_run(pTHX_ PerlIO* f) { PerlIO_lockcnt(f)++; PERL_ASYNC_CHECK(); if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) { - LEAVE; - return 0; + LEAVE; + return 0; } /* we've just run some perl-level code that could have done * anything, including closing the file or clearing this layer. * If so, free any lower layers that have already been * cleared, then return an error. */ while (PerlIOValid(f) && - (PerlIOBase(f)->flags & PERLIO_F_CLEARED)) + (PerlIOBase(f)->flags & PERLIO_F_CLEARED)) { - const PerlIOl *l = *f; - *f = l->next; - Safefree(l); + const PerlIOl *l = *f; + *f = l->next; + Safefree(l); } LEAVE; return 1; @@ -2502,35 +2502,35 @@ PerlIOUnix_oflags(const char *mode) { int oflags = -1; if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC) - mode++; + mode++; switch (*mode) { case 'r': - oflags = O_RDONLY; - if (*++mode == '+') { - oflags = O_RDWR; - mode++; - } - break; + oflags = O_RDONLY; + if (*++mode == '+') { + oflags = O_RDWR; + mode++; + } + break; case 'w': - oflags = O_CREAT | O_TRUNC; - if (*++mode == '+') { - oflags |= O_RDWR; - mode++; - } - else - oflags |= O_WRONLY; - break; + oflags = O_CREAT | O_TRUNC; + if (*++mode == '+') { + oflags |= O_RDWR; + mode++; + } + else + oflags |= O_WRONLY; + break; case 'a': - oflags = O_CREAT | O_APPEND; - if (*++mode == '+') { - oflags |= O_RDWR; - mode++; - } - else - oflags |= O_WRONLY; - break; + oflags = O_CREAT | O_APPEND; + if (*++mode == '+') { + oflags |= O_RDWR; + mode++; + } + else + oflags |= O_WRONLY; + break; } /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */ @@ -2542,35 +2542,35 @@ PerlIOUnix_oflags(const char *mode) case 'b': #if O_TEXT != O_BINARY oflags |= O_BINARY; - oflags &= ~O_TEXT; + oflags &= ~O_TEXT; #endif mode++; break; case 't': #if O_TEXT != O_BINARY - oflags |= O_TEXT; - oflags &= ~O_BINARY; + oflags |= O_TEXT; + oflags &= ~O_BINARY; #endif mode++; break; default: #if O_BINARY != 0 /* bit-or:ing with zero O_BINARY would be useless. */ - /* - * If neither "t" nor "b" was specified, open the file - * in O_BINARY mode. + /* + * If neither "t" nor "b" was specified, open the file + * in O_BINARY mode. * * Note that if something else than the zero byte was seen * here (e.g. bogus mode "rx"), just few lines later we will * set the errno and invalidate the flags. - */ - oflags |= O_BINARY; + */ + oflags |= O_BINARY; #endif break; } if (*mode || oflags == -1) { - SETERRNO(EINVAL, LIB_INVARG); - oflags = -1; + SETERRNO(EINVAL, LIB_INVARG); + oflags = -1; } return oflags; } @@ -2589,13 +2589,13 @@ PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode) #if defined(WIN32) Stat_t st; if (PerlLIO_fstat(fd, &st) == 0) { - if (!S_ISREG(st.st_mode)) { - DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) ); - PerlIOBase(f)->flags |= PERLIO_F_NOTREG; - } - else { - DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) ); - } + if (!S_ISREG(st.st_mode)) { + DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) ); + PerlIOBase(f)->flags |= PERLIO_F_NOTREG; + } + else { + DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) ); + } } #endif s->fd = fd; @@ -2609,13 +2609,13 @@ PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) { IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); if (*PerlIONext(f)) { - /* We never call down so do any pending stuff now */ - PerlIO_flush(PerlIONext(f)); - /* - * XXX could (or should) we retrieve the oflags from the open file - * handle rather than believing the "mode" we are passed in? XXX - * Should the value on NULL mode be 0 or -1? - */ + /* We never call down so do any pending stuff now */ + PerlIO_flush(PerlIONext(f)); + /* + * XXX could (or should) we retrieve the oflags from the open file + * handle rather than believing the "mode" we are passed in? XXX + * Should the value on NULL mode be 0 or -1? + */ PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)), mode ? PerlIOUnix_oflags(mode) : -1); } @@ -2632,79 +2632,79 @@ PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence) PERL_UNUSED_CONTEXT; if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) { #ifdef ESPIPE - SETERRNO(ESPIPE, LIB_INVARG); + SETERRNO(ESPIPE, LIB_INVARG); #else - SETERRNO(EINVAL, LIB_INVARG); + SETERRNO(EINVAL, LIB_INVARG); #endif - return -1; + return -1; } new_loc = PerlLIO_lseek(fd, offset, whence); if (new_loc == (Off_t) - 1) - return -1; + return -1; PerlIOBase(f)->flags &= ~PERLIO_F_EOF; return 0; } PerlIO * PerlIOUnix_open(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) + IV n, const char *mode, int fd, int imode, + int perm, PerlIO *f, int narg, SV **args) { bool known_cloexec = 0; if (PerlIOValid(f)) { - if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN) - (*PerlIOBase(f)->tab->Close)(aTHX_ f); + if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN) + (*PerlIOBase(f)->tab->Close)(aTHX_ f); } if (narg > 0) { - if (*mode == IoTYPE_NUMERIC) - mode++; - else { - imode = PerlIOUnix_oflags(mode); + if (*mode == IoTYPE_NUMERIC) + mode++; + else { + imode = PerlIOUnix_oflags(mode); #ifdef VMS - perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */ + perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */ #else - perm = 0666; + perm = 0666; #endif - } - if (imode != -1) { + } + if (imode != -1) { STRLEN len; - const char *path = SvPV_const(*args, len); - if (!IS_SAFE_PATHNAME(path, len, "open")) + const char *path = SvPV_const(*args, len); + if (!IS_SAFE_PATHNAME(path, len, "open")) return NULL; - fd = PerlLIO_open3_cloexec(path, imode, perm); - known_cloexec = 1; - } + fd = PerlLIO_open3_cloexec(path, imode, perm); + known_cloexec = 1; + } } if (fd >= 0) { - if (known_cloexec) - setfd_inhexec_for_sysfd(fd); - else - setfd_cloexec_or_inhexec_by_sysfdness(fd); - if (*mode == IoTYPE_IMPLICIT) - mode++; - if (!f) { - f = PerlIO_allocate(aTHX); - } - if (!PerlIOValid(f)) { - if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { - PerlLIO_close(fd); - return NULL; - } - } + if (known_cloexec) + setfd_inhexec_for_sysfd(fd); + else + setfd_cloexec_or_inhexec_by_sysfdness(fd); + if (*mode == IoTYPE_IMPLICIT) + mode++; + if (!f) { + f = PerlIO_allocate(aTHX); + } + if (!PerlIOValid(f)) { + if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { + PerlLIO_close(fd); + return NULL; + } + } PerlIOUnix_setfd(aTHX_ f, fd, imode); - PerlIOBase(f)->flags |= PERLIO_F_OPEN; - if (*mode == IoTYPE_APPEND) - PerlIOUnix_seek(aTHX_ f, 0, SEEK_END); - return f; + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + if (*mode == IoTYPE_APPEND) + PerlIOUnix_seek(aTHX_ f, 0, SEEK_END); + return f; } else { - if (f) { - NOOP; - /* - * FIXME: pop layers ??? - */ - } - return NULL; + if (f) { + NOOP; + /* + * FIXME: pop layers ??? + */ + } + return NULL; } } @@ -2714,17 +2714,17 @@ PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix); int fd = os->fd; if (flags & PERLIO_DUP_FD) { - fd = PerlLIO_dup_cloexec(fd); - if (fd >= 0) - setfd_inhexec_for_sysfd(fd); + fd = PerlLIO_dup_cloexec(fd); + if (fd >= 0) + setfd_inhexec_for_sysfd(fd); } if (fd >= 0) { - f = PerlIOBase_dup(aTHX_ f, o, param, flags); - if (f) { - /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */ - PerlIOUnix_setfd(aTHX_ f, fd, os->oflags); - return f; - } + f = PerlIOBase_dup(aTHX_ f, o, param, flags); + if (f) { + /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */ + PerlIOUnix_setfd(aTHX_ f, fd, os->oflags); + return f; + } PerlLIO_close(fd); } return NULL; @@ -2736,30 +2736,30 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { int fd; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ - return -1; + return -1; fd = PerlIOSelf(f, PerlIOUnix)->fd; if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) || PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) { - return 0; + return 0; } while (1) { - const SSize_t len = PerlLIO_read(fd, vbuf, count); - if (len >= 0 || errno != EINTR) { - if (len < 0) { - if (errno != EAGAIN) { - PerlIOBase(f)->flags |= PERLIO_F_ERROR; - PerlIO_save_errno(f); - } - } - else if (len == 0 && count != 0) { - PerlIOBase(f)->flags |= PERLIO_F_EOF; - SETERRNO(0,0); - } - return len; - } - /* EINTR */ - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; + const SSize_t len = PerlLIO_read(fd, vbuf, count); + if (len >= 0 || errno != EINTR) { + if (len < 0) { + if (errno != EAGAIN) { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); + } + } + else if (len == 0 && count != 0) { + PerlIOBase(f)->flags |= PERLIO_F_EOF; + SETERRNO(0,0); + } + return len; + } + /* EINTR */ + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; } NOT_REACHED; /*NOTREACHED*/ } @@ -2769,22 +2769,22 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { int fd; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ - return -1; + return -1; fd = PerlIOSelf(f, PerlIOUnix)->fd; while (1) { - const SSize_t len = PerlLIO_write(fd, vbuf, count); - if (len >= 0 || errno != EINTR) { - if (len < 0) { - if (errno != EAGAIN) { - PerlIOBase(f)->flags |= PERLIO_F_ERROR; - PerlIO_save_errno(f); - } - } - return len; - } - /* EINTR */ - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; + const SSize_t len = PerlLIO_write(fd, vbuf, count); + if (len >= 0 || errno != EINTR) { + if (len < 0) { + if (errno != EAGAIN) { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); + } + } + return len; + } + /* EINTR */ + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; } NOT_REACHED; /*NOTREACHED*/ } @@ -2805,26 +2805,26 @@ PerlIOUnix_close(pTHX_ PerlIO *f) int code = 0; if (PerlIOBase(f)->flags & PERLIO_F_OPEN) { code = PerlIOBase_close(aTHX_ f); - if (PerlIOUnix_refcnt_dec(fd) > 0) { - PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; - return 0; - } + if (PerlIOUnix_refcnt_dec(fd) > 0) { + PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; + return 0; + } } else { - SETERRNO(EBADF,SS_IVCHAN); - return -1; + SETERRNO(EBADF,SS_IVCHAN); + return -1; } while (PerlLIO_close(fd) != 0) { - if (errno != EINTR) { - code = -1; - break; - } - /* EINTR */ - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; + if (errno != EINTR) { + code = -1; + break; + } + /* EINTR */ + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; } if (code == 0) { - PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; + PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; } return code; } @@ -2884,9 +2884,9 @@ PerlIOStdio_fileno(pTHX_ PerlIO *f) PERL_UNUSED_CONTEXT; if (PerlIOValid(f)) { - FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio; - if (s) - return PerlSIO_fileno(s); + FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio; + if (s) + return PerlSIO_fileno(s); } errno = EBADF; return -1; @@ -2897,9 +2897,9 @@ PerlIOStdio_mode(const char *mode, char *tmode) { char * const ret = tmode; if (mode) { - while (*mode) { - *tmode++ = *mode++; - } + while (*mode) { + *tmode++ = *mode++; + } } #if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__) *tmode++ = 'b'; @@ -2913,25 +2913,25 @@ PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab { PerlIO *n; if (PerlIOValid(f) && PerlIOValid(n = PerlIONext(f))) { - PerlIO_funcs * const toptab = PerlIOBase(n)->tab; + PerlIO_funcs * const toptab = PerlIOBase(n)->tab; if (toptab == tab) { - /* Top is already stdio - pop self (duplicate) and use original */ - PerlIO_pop(aTHX_ f); - return 0; - } else { - const int fd = PerlIO_fileno(n); - char tmode[8]; - FILE *stdio; - if (fd >= 0 && (stdio = PerlSIO_fdopen(fd, - mode = PerlIOStdio_mode(mode, tmode)))) { - PerlIOSelf(f, PerlIOStdio)->stdio = stdio; - /* We never call down so do any pending stuff now */ - PerlIO_flush(PerlIONext(f)); + /* Top is already stdio - pop self (duplicate) and use original */ + PerlIO_pop(aTHX_ f); + return 0; + } else { + const int fd = PerlIO_fileno(n); + char tmode[8]; + FILE *stdio; + if (fd >= 0 && (stdio = PerlSIO_fdopen(fd, + mode = PerlIOStdio_mode(mode, tmode)))) { + PerlIOSelf(f, PerlIOStdio)->stdio = stdio; + /* We never call down so do any pending stuff now */ + PerlIO_flush(PerlIONext(f)); return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); - } - else { - return -1; - } + } + else { + return -1; + } } } return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); @@ -2944,182 +2944,182 @@ PerlIO_importFILE(FILE *stdio, const char *mode) dTHX; PerlIO *f = NULL; #ifdef EBCDIC - int rc; - char filename[FILENAME_MAX]; - fldata_t fileinfo; + int rc; + char filename[FILENAME_MAX]; + fldata_t fileinfo; #endif if (stdio) { - PerlIOStdio *s; + PerlIOStdio *s; int fd0 = fileno(stdio); if (fd0 < 0) { #ifdef EBCDIC - rc = fldata(stdio,filename,&fileinfo); - if(rc != 0){ - return NULL; - } - if(fileinfo.__dsorgHFS){ + rc = fldata(stdio,filename,&fileinfo); + if(rc != 0){ + return NULL; + } + if(fileinfo.__dsorgHFS){ return NULL; } - /*This MVS dataset , OK!*/ + /*This MVS dataset , OK!*/ #else return NULL; #endif } - if (!mode || !*mode) { - /* We need to probe to see how we can open the stream - so start with read/write and then try write and read - we dup() so that we can fclose without loosing the fd. - - Note that the errno value set by a failing fdopen - varies between stdio implementations. - */ + if (!mode || !*mode) { + /* We need to probe to see how we can open the stream + so start with read/write and then try write and read + we dup() so that we can fclose without loosing the fd. + + Note that the errno value set by a failing fdopen + varies between stdio implementations. + */ const int fd = PerlLIO_dup_cloexec(fd0); - FILE *f2; + FILE *f2; if (fd < 0) { return f; } - f2 = PerlSIO_fdopen(fd, (mode = "r+")); - if (!f2) { - f2 = PerlSIO_fdopen(fd, (mode = "w")); - } - if (!f2) { - f2 = PerlSIO_fdopen(fd, (mode = "r")); - } - if (!f2) { - /* Don't seem to be able to open */ - PerlLIO_close(fd); - return f; - } - fclose(f2); - } - if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) { - s = PerlIOSelf(f, PerlIOStdio); - s->stdio = stdio; - fd0 = fileno(stdio); - if(fd0 != -1){ - PerlIOUnix_refcnt_inc(fd0); - setfd_cloexec_or_inhexec_by_sysfdness(fd0); - } + f2 = PerlSIO_fdopen(fd, (mode = "r+")); + if (!f2) { + f2 = PerlSIO_fdopen(fd, (mode = "w")); + } + if (!f2) { + f2 = PerlSIO_fdopen(fd, (mode = "r")); + } + if (!f2) { + /* Don't seem to be able to open */ + PerlLIO_close(fd); + return f; + } + fclose(f2); + } + if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) { + s = PerlIOSelf(f, PerlIOStdio); + s->stdio = stdio; + fd0 = fileno(stdio); + if(fd0 != -1){ + PerlIOUnix_refcnt_inc(fd0); + setfd_cloexec_or_inhexec_by_sysfdness(fd0); + } #ifdef EBCDIC - else{ - rc = fldata(stdio,filename,&fileinfo); - if(rc != 0){ - PerlIOUnix_refcnt_inc(fd0); - } - if(fileinfo.__dsorgHFS){ - PerlIOUnix_refcnt_inc(fd0); - } - /*This MVS dataset , OK!*/ - } + else{ + rc = fldata(stdio,filename,&fileinfo); + if(rc != 0){ + PerlIOUnix_refcnt_inc(fd0); + } + if(fileinfo.__dsorgHFS){ + PerlIOUnix_refcnt_inc(fd0); + } + /*This MVS dataset , OK!*/ + } #endif - } + } } return f; } PerlIO * PerlIOStdio_open(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) + IV n, const char *mode, int fd, int imode, + int perm, PerlIO *f, int narg, SV **args) { char tmode[8]; if (PerlIOValid(f)) { STRLEN len; - const char * const path = SvPV_const(*args, len); - PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio); - FILE *stdio; - if (!IS_SAFE_PATHNAME(path, len, "open")) + const char * const path = SvPV_const(*args, len); + PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio); + FILE *stdio; + if (!IS_SAFE_PATHNAME(path, len, "open")) return NULL; - PerlIOUnix_refcnt_dec(fileno(s->stdio)); - stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode), + PerlIOUnix_refcnt_dec(fileno(s->stdio)); + stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode), s->stdio); - if (!s->stdio) - return NULL; - s->stdio = stdio; - fd = fileno(stdio); - PerlIOUnix_refcnt_inc(fd); - setfd_cloexec_or_inhexec_by_sysfdness(fd); - return f; + if (!s->stdio) + return NULL; + s->stdio = stdio; + fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); + return f; } else { - if (narg > 0) { + if (narg > 0) { STRLEN len; - const char * const path = SvPV_const(*args, len); + const char * const path = SvPV_const(*args, len); if (!IS_SAFE_PATHNAME(path, len, "open")) return NULL; - if (*mode == IoTYPE_NUMERIC) { - mode++; - fd = PerlLIO_open3_cloexec(path, imode, perm); - } - else { - FILE *stdio; - bool appended = FALSE; + if (*mode == IoTYPE_NUMERIC) { + mode++; + fd = PerlLIO_open3_cloexec(path, imode, perm); + } + else { + FILE *stdio; + bool appended = FALSE; #ifdef __CYGWIN__ - /* Cygwin wants its 'b' early. */ - appended = TRUE; - mode = PerlIOStdio_mode(mode, tmode); + /* Cygwin wants its 'b' early. */ + appended = TRUE; + mode = PerlIOStdio_mode(mode, tmode); #endif - stdio = PerlSIO_fopen(path, mode); - if (stdio) { - if (!f) { - f = PerlIO_allocate(aTHX); - } - if (!appended) - mode = PerlIOStdio_mode(mode, tmode); - f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg); - if (f) { - PerlIOSelf(f, PerlIOStdio)->stdio = stdio; - fd = fileno(stdio); - PerlIOUnix_refcnt_inc(fd); - setfd_cloexec_or_inhexec_by_sysfdness(fd); - } else { - PerlSIO_fclose(stdio); - } - return f; - } - else { - return NULL; - } - } - } - if (fd >= 0) { - FILE *stdio = NULL; - int init = 0; - if (*mode == IoTYPE_IMPLICIT) { - init = 1; - mode++; - } - if (init) { - switch (fd) { - case 0: - stdio = PerlSIO_stdin; - break; - case 1: - stdio = PerlSIO_stdout; - break; - case 2: - stdio = PerlSIO_stderr; - break; - } - } - else { - stdio = PerlSIO_fdopen(fd, mode = - PerlIOStdio_mode(mode, tmode)); - } - if (stdio) { - if (!f) { - f = PerlIO_allocate(aTHX); - } - if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { - PerlIOSelf(f, PerlIOStdio)->stdio = stdio; - fd = fileno(stdio); - PerlIOUnix_refcnt_inc(fd); - setfd_cloexec_or_inhexec_by_sysfdness(fd); - } - return f; - } + stdio = PerlSIO_fopen(path, mode); + if (stdio) { + if (!f) { + f = PerlIO_allocate(aTHX); + } + if (!appended) + mode = PerlIOStdio_mode(mode, tmode); + f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg); + if (f) { + PerlIOSelf(f, PerlIOStdio)->stdio = stdio; + fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); + } else { + PerlSIO_fclose(stdio); + } + return f; + } + else { + return NULL; + } + } + } + if (fd >= 0) { + FILE *stdio = NULL; + int init = 0; + if (*mode == IoTYPE_IMPLICIT) { + init = 1; + mode++; + } + if (init) { + switch (fd) { + case 0: + stdio = PerlSIO_stdin; + break; + case 1: + stdio = PerlSIO_stdout; + break; + case 2: + stdio = PerlSIO_stderr; + break; + } + } + else { + stdio = PerlSIO_fdopen(fd, mode = + PerlIOStdio_mode(mode, tmode)); + } + if (stdio) { + if (!f) { + f = PerlIO_allocate(aTHX); + } + if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { + PerlIOSelf(f, PerlIOStdio)->stdio = stdio; + fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); + } + return f; + } PerlLIO_close(fd); - } + } } return NULL; } @@ -3131,29 +3131,29 @@ PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) happens, but is not how I remember it. NI-S 2001/10/16 */ if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { - FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio; - const int fd = fileno(stdio); - char mode[8]; - if (flags & PERLIO_DUP_FD) { - const int dfd = PerlLIO_dup_cloexec(fileno(stdio)); - if (dfd >= 0) { - stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode)); - goto set_this; - } - else { - NOOP; - /* FIXME: To avoid messy error recovery if dup fails - re-use the existing stdio as though flag was not set - */ - } - } - stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode)); + FILE *stdio = PerlIOSelf(o, PerlIOStdio)->stdio; + const int fd = fileno(stdio); + char mode[8]; + if (flags & PERLIO_DUP_FD) { + const int dfd = PerlLIO_dup_cloexec(fileno(stdio)); + if (dfd >= 0) { + stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode)); + goto set_this; + } + else { + NOOP; + /* FIXME: To avoid messy error recovery if dup fails + re-use the existing stdio as though flag was not set + */ + } + } + stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode)); set_this: - PerlIOSelf(f, PerlIOStdio)->stdio = stdio; + PerlIOSelf(f, PerlIOStdio)->stdio = stdio; if(stdio) { - int fd = fileno(stdio); - PerlIOUnix_refcnt_inc(fd); - setfd_cloexec_or_inhexec_by_sysfdness(fd); + int fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); } } return f; @@ -3175,7 +3175,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) return 1; #elif defined(__GLIBC__) /* There may be a better way for GLIBC: - - libio.h defines a flag to not close() on cleanup + - libio.h defines a flag to not close() on cleanup */ f->_fileno = -1; return 1; @@ -3197,14 +3197,14 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) #elif defined(__FreeBSD__) /* There may be a better way on FreeBSD: - we could insert a dummy func in the _close function entry - f->_close = (int (*)(void *)) dummy_close; + f->_close = (int (*)(void *)) dummy_close; */ f->_file = -1; return 1; #elif defined(__OpenBSD__) /* There may be a better way on OpenBSD: - we could insert a dummy func in the _close function entry - f->_close = (int (*)(void *)) dummy_close; + f->_close = (int (*)(void *)) dummy_close; */ f->_file = -1; return 1; @@ -3215,7 +3215,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) #elif defined(__CYGWIN__) /* There may be a better way on CYGWIN: - we could insert a dummy func in the _close function entry - f->_close = (int (*)(void *)) dummy_close; + f->_close = (int (*)(void *)) dummy_close; */ f->_file = -1; return 1; @@ -3239,40 +3239,40 @@ PerlIOStdio_close(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; if (!stdio) { - errno = EBADF; - return -1; + errno = EBADF; + return -1; } else { const int fd = fileno(stdio); - int invalidate = 0; - IV result = 0; - int dupfd = -1; - dSAVEDERRNO; + int invalidate = 0; + IV result = 0; + int dupfd = -1; + dSAVEDERRNO; #ifdef SOCKS5_VERSION_NAME - /* Socks lib overrides close() but stdio isn't linked to - that library (though we are) - so we must call close() - on sockets on stdio's behalf. - */ - int optval; - Sock_size_t optlen = sizeof(int); - if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) - invalidate = 1; + /* Socks lib overrides close() but stdio isn't linked to + that library (though we are) - so we must call close() + on sockets on stdio's behalf. + */ + int optval; + Sock_size_t optlen = sizeof(int); + if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) + invalidate = 1; #endif - /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such - that a subsequent fileno() on it returns -1. Don't want to croak() - from within PerlIOUnix_refcnt_dec() if some buggy caller code is - trying to close an already closed handle which somehow it still has - a reference to. (via.xs, I'm looking at you). */ - if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) { - /* File descriptor still in use */ - invalidate = 1; - } - if (invalidate) { - /* For STD* handles, don't close stdio, since we shared the FILE *, too. */ - if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */ - return 0; - if (stdio == stdout || stdio == stderr) - return PerlIO_flush(f); + /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such + that a subsequent fileno() on it returns -1. Don't want to croak() + from within PerlIOUnix_refcnt_dec() if some buggy caller code is + trying to close an already closed handle which somehow it still has + a reference to. (via.xs, I'm looking at you). */ + if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) { + /* File descriptor still in use */ + invalidate = 1; + } + if (invalidate) { + /* For STD* handles, don't close stdio, since we shared the FILE *, too. */ + if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */ + return 0; + if (stdio == stdout || stdio == stderr) + return PerlIO_flush(f); } MUTEX_LOCK(&PL_perlio_mutex); /* Right. We need a mutex here because for a brief while we @@ -3292,46 +3292,46 @@ PerlIOStdio_close(pTHX_ PerlIO *f) Except that correctness trumps speed. Advice from klortho #11912. */ - if (invalidate) { + if (invalidate) { /* Tricky - must fclose(stdio) to free memory but not close(fd) - Use Sarathy's trick from maint-5.6 to invalidate the - fileno slot of the FILE * - */ - result = PerlIO_flush(f); - SAVE_ERRNO; - invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio); - if (!invalidate) { - dupfd = PerlLIO_dup_cloexec(fd); + Use Sarathy's trick from maint-5.6 to invalidate the + fileno slot of the FILE * + */ + result = PerlIO_flush(f); + SAVE_ERRNO; + invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio); + if (!invalidate) { + dupfd = PerlLIO_dup_cloexec(fd); #ifdef USE_ITHREADS - if (dupfd < 0) { - /* Oh cXap. This isn't going to go well. Not sure if we can - recover from here, or if closing this particular FILE * - is a good idea now. */ - } + if (dupfd < 0) { + /* Oh cXap. This isn't going to go well. Not sure if we can + recover from here, or if closing this particular FILE * + is a good idea now. */ + } #endif - } - } else { - SAVE_ERRNO; /* This is here only to silence compiler warnings */ - } + } + } else { + SAVE_ERRNO; /* This is here only to silence compiler warnings */ + } result = PerlSIO_fclose(stdio); - /* We treat error from stdio as success if we invalidated - errno may NOT be expected EBADF - */ - if (invalidate && result != 0) { - RESTORE_ERRNO; - result = 0; - } + /* We treat error from stdio as success if we invalidated + errno may NOT be expected EBADF + */ + if (invalidate && result != 0) { + RESTORE_ERRNO; + result = 0; + } #ifdef SOCKS5_VERSION_NAME - /* in SOCKS' case, let close() determine return value */ - result = close(fd); + /* in SOCKS' case, let close() determine return value */ + result = close(fd); #endif - if (dupfd >= 0) { - PerlLIO_dup2_cloexec(dupfd, fd); - setfd_inhexec_for_sysfd(fd); - PerlLIO_close(dupfd); - } + if (dupfd >= 0) { + PerlLIO_dup2_cloexec(dupfd, fd); + setfd_inhexec_for_sysfd(fd); + PerlLIO_close(dupfd); + } MUTEX_UNLOCK(&PL_perlio_mutex); - return result; + return result; } } @@ -3341,30 +3341,30 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) FILE * s; SSize_t got = 0; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ - return -1; + return -1; s = PerlIOSelf(f, PerlIOStdio)->stdio; for (;;) { - if (count == 1) { - STDCHAR *buf = (STDCHAR *) vbuf; - /* - * Perl is expecting PerlIO_getc() to fill the buffer Linux's - * stdio does not do that for fread() - */ - const int ch = PerlSIO_fgetc(s); - if (ch != EOF) { - *buf = ch; - got = 1; - } - } - else - got = PerlSIO_fread(vbuf, 1, count, s); - if (got == 0 && PerlSIO_ferror(s)) - got = -1; - if (got >= 0 || errno != EINTR) - break; - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; - SETERRNO(0,0); /* just in case */ + if (count == 1) { + STDCHAR *buf = (STDCHAR *) vbuf; + /* + * Perl is expecting PerlIO_getc() to fill the buffer Linux's + * stdio does not do that for fread() + */ + const int ch = PerlSIO_fgetc(s); + if (ch != EOF) { + *buf = ch; + got = 1; + } + } + else + got = PerlSIO_fread(vbuf, 1, count, s); + if (got == 0 && PerlSIO_ferror(s)) + got = -1; + if (got >= 0 || errno != EINTR) + break; + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; + SETERRNO(0,0); /* just in case */ } #ifdef __sgi /* Under some circumstances IRIX stdio fgetc() and fread() @@ -3383,52 +3383,52 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) #ifdef STDIO_BUFFER_WRITABLE if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { - STDCHAR *buf = ((STDCHAR *) vbuf) + count; - STDCHAR *base = PerlIO_get_base(f); - SSize_t cnt = PerlIO_get_cnt(f); - STDCHAR *ptr = PerlIO_get_ptr(f); - SSize_t avail = ptr - base; - if (avail > 0) { - if (avail > count) { - avail = count; - } - ptr -= avail; - Move(buf-avail,ptr,avail,STDCHAR); - count -= avail; - unread += avail; - PerlIO_set_ptrcnt(f,ptr,cnt+avail); - if (PerlSIO_feof(s) && unread >= 0) - PerlSIO_clearerr(s); - } + STDCHAR *buf = ((STDCHAR *) vbuf) + count; + STDCHAR *base = PerlIO_get_base(f); + SSize_t cnt = PerlIO_get_cnt(f); + STDCHAR *ptr = PerlIO_get_ptr(f); + SSize_t avail = ptr - base; + if (avail > 0) { + if (avail > count) { + avail = count; + } + ptr -= avail; + Move(buf-avail,ptr,avail,STDCHAR); + count -= avail; + unread += avail; + PerlIO_set_ptrcnt(f,ptr,cnt+avail); + if (PerlSIO_feof(s) && unread >= 0) + PerlSIO_clearerr(s); + } } else #endif if (PerlIO_has_cntptr(f)) { - /* We can get pointer to buffer but not its base - Do ungetc() but check chars are ending up in the - buffer - */ - STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s); - STDCHAR *buf = ((STDCHAR *) vbuf) + count; - while (count > 0) { - const int ch = *--buf & 0xFF; - if (ungetc(ch,s) != ch) { - /* ungetc did not work */ - break; - } - if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) { - /* Did not change pointer as expected */ - if (fgetc(s) != EOF) /* get char back again */ + /* We can get pointer to buffer but not its base + Do ungetc() but check chars are ending up in the + buffer + */ + STDCHAR *eptr = (STDCHAR*)PerlSIO_get_ptr(s); + STDCHAR *buf = ((STDCHAR *) vbuf) + count; + while (count > 0) { + const int ch = *--buf & 0xFF; + if (ungetc(ch,s) != ch) { + /* ungetc did not work */ + break; + } + if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) { + /* Did not change pointer as expected */ + if (fgetc(s) != EOF) /* get char back again */ break; - } - /* It worked ! */ - count--; - unread++; - } + } + /* It worked ! */ + count--; + unread++; + } } if (count > 0) { - unread += PerlIOBase_unread(aTHX_ f, vbuf, count); + unread += PerlIOBase_unread(aTHX_ f, vbuf, count); } return unread; } @@ -3438,15 +3438,15 @@ PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { SSize_t got; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ - return -1; + return -1; for (;;) { - got = PerlSIO_fwrite(vbuf, 1, count, - PerlIOSelf(f, PerlIOStdio)->stdio); - if (got >= 0 || errno != EINTR) - break; - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; - SETERRNO(0,0); /* just in case */ + got = PerlSIO_fwrite(vbuf, 1, count, + PerlIOSelf(f, PerlIOStdio)->stdio); + if (got >= 0 || errno != EINTR) + break; + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; + SETERRNO(0,0); /* just in case */ } return got; } @@ -3476,23 +3476,23 @@ PerlIOStdio_flush(pTHX_ PerlIO *f) PERL_UNUSED_CONTEXT; if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { - return PerlSIO_fflush(stdio); + return PerlSIO_fflush(stdio); } else { - NOOP; + NOOP; #if 0 - /* - * FIXME: This discards ungetc() and pre-read stuff which is not - * right if this is just a "sync" from a layer above Suspect right - * design is to do _this_ but not have layer above flush this - * layer read-to-read - */ - /* - * Not writeable - sync by attempting a seek - */ - dSAVE_ERRNO; - if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0) - RESTORE_ERRNO; + /* + * FIXME: This discards ungetc() and pre-read stuff which is not + * right if this is just a "sync" from a layer above Suspect right + * design is to do _this_ but not have layer above flush this + * layer read-to-read + */ + /* + * Not writeable - sync by attempting a seek + */ + dSAVE_ERRNO; + if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0) + RESTORE_ERRNO; #endif } return 0; @@ -3588,19 +3588,19 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) * * So let's try silencing the warning at least for gcc. */ GCC_DIAG_IGNORE_STMT(-Wpointer-sign); - PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */ + PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */ GCC_DIAG_RESTORE_STMT; # ifdef STDIO_PTR_LVAL_SETS_CNT - assert(PerlSIO_get_cnt(stdio) == (cnt)); + assert(PerlSIO_get_cnt(stdio) == (cnt)); # endif # if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT)) - /* - * Setting ptr _does_ change cnt - we are done - */ - return; + /* + * Setting ptr _does_ change cnt - we are done + */ + return; # endif # else /* STDIO_PTR_LVALUE */ - PerlProc_abort(); + PerlProc_abort(); # endif /* STDIO_PTR_LVALUE */ } /* @@ -3610,8 +3610,8 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) PerlSIO_set_cnt(stdio, cnt); # elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) PerlSIO_set_ptr(stdio, - PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) - - cnt)); + PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) - + cnt)); # else /* STDIO_PTR_LVAL_SETS_CNT */ PerlProc_abort(); # endif /* STDIO_CNT_LVALUE */ @@ -3627,52 +3627,52 @@ PerlIOStdio_fill(pTHX_ PerlIO *f) int c; PERL_UNUSED_CONTEXT; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ - return -1; + return -1; stdio = PerlIOSelf(f, PerlIOStdio)->stdio; /* * fflush()ing read-only streams can cause trouble on some stdio-s */ if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) { - if (PerlSIO_fflush(stdio) != 0) - return EOF; + if (PerlSIO_fflush(stdio) != 0) + return EOF; } for (;;) { - c = PerlSIO_fgetc(stdio); - if (c != EOF) - break; - if (! PerlSIO_ferror(stdio) || errno != EINTR) - return EOF; - if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) - return -1; - SETERRNO(0,0); + c = PerlSIO_fgetc(stdio); + if (c != EOF) + break; + if (! PerlSIO_ferror(stdio) || errno != EINTR) + return EOF; + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; + SETERRNO(0,0); } #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) # ifdef STDIO_BUFFER_WRITABLE if (PerlIO_fast_gets(f) && PerlIO_has_base(f)) { - /* Fake ungetc() to the real buffer in case system's ungetc - goes elsewhere - */ - STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio); - SSize_t cnt = PerlSIO_get_cnt(stdio); - STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio); - if (ptr == base+1) { - *--ptr = (STDCHAR) c; - PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1); - if (PerlSIO_feof(stdio)) - PerlSIO_clearerr(stdio); - return 0; - } + /* Fake ungetc() to the real buffer in case system's ungetc + goes elsewhere + */ + STDCHAR *base = (STDCHAR*)PerlSIO_get_base(stdio); + SSize_t cnt = PerlSIO_get_cnt(stdio); + STDCHAR *ptr = (STDCHAR*)PerlSIO_get_ptr(stdio); + if (ptr == base+1) { + *--ptr = (STDCHAR) c; + PerlIOStdio_set_ptrcnt(aTHX_ f,ptr,cnt+1); + if (PerlSIO_feof(stdio)) + PerlSIO_clearerr(stdio); + return 0; + } } else # endif if (PerlIO_has_cntptr(f)) { - STDCHAR ch = c; - if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) { - return 0; - } + STDCHAR ch = c; + if (PerlIOStdio_unread(aTHX_ f,&ch,1) == 1) { + return 0; + } } #endif @@ -3680,7 +3680,7 @@ PerlIOStdio_fill(pTHX_ PerlIO *f) using ungetc(). */ if (PerlSIO_ungetc(c, stdio) != c) - return EOF; + return EOF; return 0; } @@ -3741,33 +3741,33 @@ PerlIO_exportFILE(PerlIO * f, const char *mode) dTHX; FILE *stdio = NULL; if (PerlIOValid(f)) { - char buf[8]; + char buf[8]; int fd = PerlIO_fileno(f); if (fd < 0) { return NULL; } - PerlIO_flush(f); - if (!mode || !*mode) { - mode = PerlIO_modestr(f, buf); - } - stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode); - if (stdio) { - PerlIOl *l = *f; - PerlIO *f2; - /* De-link any lower layers so new :stdio sticks */ - *f = NULL; - if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) { - PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio); - s->stdio = stdio; - PerlIOUnix_refcnt_inc(fileno(stdio)); - /* Link previous lower layers under new one */ - *PerlIONext(f) = l; - } - else { - /* restore layers list */ - *f = l; - } - } + PerlIO_flush(f); + if (!mode || !*mode) { + mode = PerlIO_modestr(f, buf); + } + stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode); + if (stdio) { + PerlIOl *l = *f; + PerlIO *f2; + /* De-link any lower layers so new :stdio sticks */ + *f = NULL; + if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) { + PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio); + s->stdio = stdio; + PerlIOUnix_refcnt_inc(fileno(stdio)); + /* Link previous lower layers under new one */ + *PerlIONext(f) = l; + } + else { + /* restore layers list */ + *f = l; + } + } } return stdio; } @@ -3779,11 +3779,11 @@ PerlIO_findFILE(PerlIO *f) PerlIOl *l = *f; FILE *stdio; while (l) { - if (l->tab == &PerlIO_stdio) { - PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); - return s->stdio; - } - l = *PerlIONext(&l); + if (l->tab == &PerlIO_stdio) { + PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); + return s->stdio; + } + l = *PerlIONext(&l); } /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */ /* However, we're not really exporting a FILE * to someone else (who @@ -3794,9 +3794,9 @@ PerlIO_findFILE(PerlIO *f) only one way to be consistent. */ stdio = PerlIO_exportFILE(f, NULL); if (stdio) { - const int fd = fileno(stdio); - if (fd >= 0) - PerlIOUnix_refcnt_dec(fd); + const int fd = fileno(stdio); + if (fd >= 0) + PerlIOUnix_refcnt_dec(fd); } return stdio; } @@ -3807,20 +3807,20 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f) { PerlIOl *l; while ((l = *p)) { - if (l->tab == &PerlIO_stdio) { - PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); - if (s->stdio == f) { /* not in a loop */ - const int fd = fileno(f); - if (fd >= 0) - PerlIOUnix_refcnt_dec(fd); - { - dTHX; - PerlIO_pop(aTHX_ p); - } - return; - } - } - p = PerlIONext(p); + if (l->tab == &PerlIO_stdio) { + PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); + if (s->stdio == f) { /* not in a loop */ + const int fd = fileno(f); + if (fd >= 0) + PerlIOUnix_refcnt_dec(fd); + { + dTHX; + PerlIO_pop(aTHX_ p); + } + return; + } + } + p = PerlIONext(p); } return; } @@ -3836,91 +3836,91 @@ PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); const int fd = PerlIO_fileno(f); if (fd >= 0 && PerlLIO_isatty(fd)) { - PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY; + PerlIOBase(f)->flags |= PERLIO_F_LINEBUF | PERLIO_F_TTY; } if (*PerlIONext(f)) { - const Off_t posn = PerlIO_tell(PerlIONext(f)); - if (posn != (Off_t) - 1) { - b->posn = posn; - } + const Off_t posn = PerlIO_tell(PerlIONext(f)); + if (posn != (Off_t) - 1) { + b->posn = posn; + } } return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); } PerlIO * PerlIOBuf_open(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) + IV n, const char *mode, int fd, int imode, int perm, + PerlIO *f, int narg, SV **args) { if (PerlIOValid(f)) { - PerlIO *next = PerlIONext(f); - PerlIO_funcs *tab = - PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab); - if (tab && tab->Open) - next = - (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, - next, narg, args); - if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) { - return NULL; - } + PerlIO *next = PerlIONext(f); + PerlIO_funcs *tab = + PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab); + if (tab && tab->Open) + next = + (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, + next, narg, args); + if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) { + return NULL; + } } else { - PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm()); - int init = 0; - if (*mode == IoTYPE_IMPLICIT) { - init = 1; - /* - * mode++; - */ - } - if (tab && tab->Open) - f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, - f, narg, args); - else - SETERRNO(EINVAL, LIB_INVARG); - if (f) { - if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { - /* - * if push fails during open, open fails. close will pop us. - */ - PerlIO_close (f); - return NULL; - } else { - fd = PerlIO_fileno(f); - if (init && fd == 2) { - /* - * Initial stderr is unbuffered - */ - PerlIOBase(f)->flags |= PERLIO_F_UNBUF; - } + PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm()); + int init = 0; + if (*mode == IoTYPE_IMPLICIT) { + init = 1; + /* + * mode++; + */ + } + if (tab && tab->Open) + f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, + f, narg, args); + else + SETERRNO(EINVAL, LIB_INVARG); + if (f) { + if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { + /* + * if push fails during open, open fails. close will pop us. + */ + PerlIO_close (f); + return NULL; + } else { + fd = PerlIO_fileno(f); + if (init && fd == 2) { + /* + * Initial stderr is unbuffered + */ + PerlIOBase(f)->flags |= PERLIO_F_UNBUF; + } #ifdef PERLIO_USING_CRLF # ifdef PERLIO_IS_BINMODE_FD - if (PERLIO_IS_BINMODE_FD(fd)) - PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL); - else + if (PERLIO_IS_BINMODE_FD(fd)) + PerlIO_binmode(aTHX_ f, '<'/*not used*/, O_BINARY, NULL); + else # endif - /* - * do something about failing setmode()? --jhi - */ - PerlLIO_setmode(fd, O_BINARY); + /* + * do something about failing setmode()? --jhi + */ + PerlLIO_setmode(fd, O_BINARY); #endif #ifdef VMS - /* Enable line buffering with record-oriented regular files - * so we don't introduce an extraneous record boundary when - * the buffer fills up. - */ - if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { - Stat_t st; - if (PerlLIO_fstat(fd, &st) == 0 - && S_ISREG(st.st_mode) - && (st.st_fab_rfm == FAB$C_VAR - || st.st_fab_rfm == FAB$C_VFC)) { - PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; - } - } + /* Enable line buffering with record-oriented regular files + * so we don't introduce an extraneous record boundary when + * the buffer fills up. + */ + if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { + Stat_t st; + if (PerlLIO_fstat(fd, &st) == 0 + && S_ISREG(st.st_mode) + && (st.st_fab_rfm == FAB$C_VAR + || st.st_fab_rfm == FAB$C_VFC)) { + PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; + } + } #endif - } - } + } + } } return f; } @@ -3940,54 +3940,54 @@ PerlIOBuf_flush(pTHX_ PerlIO *f) int code = 0; PerlIO *n = PerlIONext(f); if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) { - /* - * write() the buffer - */ - const STDCHAR *buf = b->buf; - const STDCHAR *p = buf; - while (p < b->ptr) { - SSize_t count = PerlIO_write(n, p, b->ptr - p); - if (count > 0) { - p += count; - } - else if (count < 0 || PerlIO_error(n)) { - PerlIOBase(f)->flags |= PERLIO_F_ERROR; - PerlIO_save_errno(f); - code = -1; - break; - } - } - b->posn += (p - buf); + /* + * write() the buffer + */ + const STDCHAR *buf = b->buf; + const STDCHAR *p = buf; + while (p < b->ptr) { + SSize_t count = PerlIO_write(n, p, b->ptr - p); + if (count > 0) { + p += count; + } + else if (count < 0 || PerlIO_error(n)) { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); + code = -1; + break; + } + } + b->posn += (p - buf); } else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { - STDCHAR *buf = PerlIO_get_base(f); - /* - * Note position change - */ - b->posn += (b->ptr - buf); - if (b->ptr < b->end) { - /* We did not consume all of it - try and seek downstream to - our logical position - */ - if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) { - /* Reload n as some layers may pop themselves on seek */ - b->posn = PerlIO_tell(n = PerlIONext(f)); - } - else { - /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read - data is lost for good - so return saying "ok" having undone - the position adjust - */ - b->posn -= (b->ptr - buf); - return code; - } - } + STDCHAR *buf = PerlIO_get_base(f); + /* + * Note position change + */ + b->posn += (b->ptr - buf); + if (b->ptr < b->end) { + /* We did not consume all of it - try and seek downstream to + our logical position + */ + if (PerlIOValid(n) && PerlIO_seek(n, b->posn, SEEK_SET) == 0) { + /* Reload n as some layers may pop themselves on seek */ + b->posn = PerlIO_tell(n = PerlIONext(f)); + } + else { + /* Seek failed (e.g. pipe or tty). Do NOT clear buffer or pre-read + data is lost for good - so return saying "ok" having undone + the position adjust + */ + b->posn -= (b->ptr - buf); + return code; + } + } } b->ptr = b->end = b->buf; PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); /* We check for Valid because of dubious decision to make PerlIO_flush(NULL) flush all */ if (PerlIOValid(n) && PerlIO_flush(n) != 0) - code = -1; + code = -1; return code; } @@ -4006,60 +4006,60 @@ PerlIOBuf_fill(pTHX_ PerlIO *f) * we would not normally be fill'ing if there was data left in anycase. */ if (PerlIO_flush(f) != 0) /* XXXX Check that its seek() succeeded?! */ - return -1; + return -1; if (PerlIOBase(f)->flags & PERLIO_F_TTY) - PerlIOBase_flush_linebuf(aTHX); + PerlIOBase_flush_linebuf(aTHX); if (!b->buf) - PerlIO_get_base(f); /* allocate via vtable */ + PerlIO_get_base(f); /* allocate via vtable */ assert(b->buf); /* The b->buf does get allocated via the vtable system. */ b->ptr = b->end = b->buf; if (!PerlIOValid(n)) { - PerlIOBase(f)->flags |= PERLIO_F_EOF; - return -1; + PerlIOBase(f)->flags |= PERLIO_F_EOF; + return -1; } if (PerlIO_fast_gets(n)) { - /* - * Layer below is also buffered. We do _NOT_ want to call its - * ->Read() because that will loop till it gets what we asked for - * which may hang on a pipe etc. Instead take anything it has to - * hand, or ask it to fill _once_. - */ - avail = PerlIO_get_cnt(n); - if (avail <= 0) { - avail = PerlIO_fill(n); - if (avail == 0) - avail = PerlIO_get_cnt(n); - else { - if (!PerlIO_error(n) && PerlIO_eof(n)) - avail = 0; - } - } - if (avail > 0) { - STDCHAR *ptr = PerlIO_get_ptr(n); - const SSize_t cnt = avail; - if (avail > (SSize_t)b->bufsiz) - avail = b->bufsiz; - Copy(ptr, b->buf, avail, STDCHAR); - PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail); - } + /* + * Layer below is also buffered. We do _NOT_ want to call its + * ->Read() because that will loop till it gets what we asked for + * which may hang on a pipe etc. Instead take anything it has to + * hand, or ask it to fill _once_. + */ + avail = PerlIO_get_cnt(n); + if (avail <= 0) { + avail = PerlIO_fill(n); + if (avail == 0) + avail = PerlIO_get_cnt(n); + else { + if (!PerlIO_error(n) && PerlIO_eof(n)) + avail = 0; + } + } + if (avail > 0) { + STDCHAR *ptr = PerlIO_get_ptr(n); + const SSize_t cnt = avail; + if (avail > (SSize_t)b->bufsiz) + avail = b->bufsiz; + Copy(ptr, b->buf, avail, STDCHAR); + PerlIO_set_ptrcnt(n, ptr + avail, cnt - avail); + } } else { - avail = PerlIO_read(n, b->ptr, b->bufsiz); + avail = PerlIO_read(n, b->ptr, b->bufsiz); } if (avail <= 0) { - if (avail == 0) - PerlIOBase(f)->flags |= PERLIO_F_EOF; - else - { - PerlIOBase(f)->flags |= PERLIO_F_ERROR; - PerlIO_save_errno(f); - } - return -1; + if (avail == 0) + PerlIOBase(f)->flags |= PERLIO_F_EOF; + else + { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); + } + return -1; } b->end = b->buf + avail; PerlIOBase(f)->flags |= PERLIO_F_RDBUF; @@ -4071,9 +4071,9 @@ PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { if (PerlIOValid(f)) { const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); - if (!b->ptr) - PerlIO_get_base(f); - return PerlIOBase_read(aTHX_ f, vbuf, count); + if (!b->ptr) + PerlIO_get_base(f); + return PerlIOBase_read(aTHX_ f, vbuf, count); } return 0; } @@ -4086,54 +4086,54 @@ PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) SSize_t unread = 0; SSize_t avail; if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) - PerlIO_flush(f); + PerlIO_flush(f); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); if (b->buf) { - if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { - /* - * Buffer is already a read buffer, we can overwrite any chars - * which have been read back to buffer start - */ - avail = (b->ptr - b->buf); - } - else { - /* - * Buffer is idle, set it up so whole buffer is available for - * unread - */ - avail = b->bufsiz; - b->end = b->buf + avail; - b->ptr = b->end; - PerlIOBase(f)->flags |= PERLIO_F_RDBUF; - /* - * Buffer extends _back_ from where we are now - */ - b->posn -= b->bufsiz; - } - if ((SSize_t) count >= 0 && avail > (SSize_t) count) { - /* - * If we have space for more than count, just move count - */ - avail = count; - } - if (avail > 0) { - b->ptr -= avail; - buf -= avail; - /* - * In simple stdio-like ungetc() case chars will be already - * there - */ - if (buf != b->ptr) { - Copy(buf, b->ptr, avail, STDCHAR); - } - count -= avail; - unread += avail; - PerlIOBase(f)->flags &= ~PERLIO_F_EOF; - } + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { + /* + * Buffer is already a read buffer, we can overwrite any chars + * which have been read back to buffer start + */ + avail = (b->ptr - b->buf); + } + else { + /* + * Buffer is idle, set it up so whole buffer is available for + * unread + */ + avail = b->bufsiz; + b->end = b->buf + avail; + b->ptr = b->end; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + /* + * Buffer extends _back_ from where we are now + */ + b->posn -= b->bufsiz; + } + if ((SSize_t) count >= 0 && avail > (SSize_t) count) { + /* + * If we have space for more than count, just move count + */ + avail = count; + } + if (avail > 0) { + b->ptr -= avail; + buf -= avail; + /* + * In simple stdio-like ungetc() case chars will be already + * there + */ + if (buf != b->ptr) { + Copy(buf, b->ptr, avail, STDCHAR); + } + count -= avail; + unread += avail; + PerlIOBase(f)->flags &= ~PERLIO_F_EOF; + } } if (count > 0) { - unread += PerlIOBase_unread(aTHX_ f, vbuf, count); + unread += PerlIOBase_unread(aTHX_ f, vbuf, count); } return unread; } @@ -4146,41 +4146,41 @@ PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) const STDCHAR *flushptr = buf; Size_t written = 0; if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) - return 0; + return 0; if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { - if (PerlIO_flush(f) != 0) { - return 0; - } + if (PerlIO_flush(f) != 0) { + return 0; + } } if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { - flushptr = buf + count; - while (flushptr > buf && *(flushptr - 1) != '\n') - --flushptr; + flushptr = buf + count; + while (flushptr > buf && *(flushptr - 1) != '\n') + --flushptr; } while (count > 0) { - SSize_t avail = b->bufsiz - (b->ptr - b->buf); - if ((SSize_t) count >= 0 && (SSize_t) count < avail) - avail = count; - if (flushptr > buf && flushptr <= buf + avail) - avail = flushptr - buf; - PerlIOBase(f)->flags |= PERLIO_F_WRBUF; - if (avail) { - Copy(buf, b->ptr, avail, STDCHAR); - count -= avail; - buf += avail; - written += avail; - b->ptr += avail; - if (buf == flushptr) - PerlIO_flush(f); - } - if (b->ptr >= (b->buf + b->bufsiz)) - if (PerlIO_flush(f) == -1) - return -1; + SSize_t avail = b->bufsiz - (b->ptr - b->buf); + if ((SSize_t) count >= 0 && (SSize_t) count < avail) + avail = count; + if (flushptr > buf && flushptr <= buf + avail) + avail = flushptr - buf; + PerlIOBase(f)->flags |= PERLIO_F_WRBUF; + if (avail) { + Copy(buf, b->ptr, avail, STDCHAR); + count -= avail; + buf += avail; + written += avail; + b->ptr += avail; + if (buf == flushptr) + PerlIO_flush(f); + } + if (b->ptr >= (b->buf + b->bufsiz)) + if (PerlIO_flush(f) == -1) + return -1; } if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) - PerlIO_flush(f); + PerlIO_flush(f); return written; } @@ -4189,12 +4189,12 @@ PerlIOBuf_seek(pTHX_ PerlIO *f, Off_t offset, int whence) { IV code; if ((code = PerlIO_flush(f)) == 0) { - PerlIOBase(f)->flags &= ~PERLIO_F_EOF; - code = PerlIO_seek(PerlIONext(f), offset, whence); - if (code == 0) { - PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); - b->posn = PerlIO_tell(PerlIONext(f)); - } + PerlIOBase(f)->flags &= ~PERLIO_F_EOF; + code = PerlIO_seek(PerlIONext(f), offset, whence); + if (code == 0) { + PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); + b->posn = PerlIO_tell(PerlIONext(f)); + } } return code; } @@ -4210,21 +4210,21 @@ PerlIOBuf_tell(pTHX_ PerlIO *f) if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) && (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) { #if 1 - /* As O_APPEND files are normally shared in some sense it is better - to flush : - */ - PerlIO_flush(f); + /* As O_APPEND files are normally shared in some sense it is better + to flush : + */ + PerlIO_flush(f); #else /* when file is NOT shared then this is sufficient */ - PerlIO_seek(PerlIONext(f),0, SEEK_END); + PerlIO_seek(PerlIONext(f),0, SEEK_END); #endif - posn = b->posn = PerlIO_tell(PerlIONext(f)); + posn = b->posn = PerlIO_tell(PerlIONext(f)); } if (b->buf) { - /* - * If buffer is valid adjust position by amount in buffer - */ - posn += (b->ptr - b->buf); + /* + * If buffer is valid adjust position by amount in buffer + */ + posn += (b->ptr - b->buf); } return posn; } @@ -4235,7 +4235,7 @@ PerlIOBuf_popped(pTHX_ PerlIO *f) const IV code = PerlIOBase_popped(aTHX_ f); PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (b->buf && b->buf != (STDCHAR *) & b->oneword) { - Safefree(b->buf); + Safefree(b->buf); } b->ptr = b->end = b->buf = NULL; PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); @@ -4248,7 +4248,7 @@ PerlIOBuf_close(pTHX_ PerlIO *f) const IV code = PerlIOBase_close(aTHX_ f); PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (b->buf && b->buf != (STDCHAR *) & b->oneword) { - Safefree(b->buf); + Safefree(b->buf); } b->ptr = b->end = b->buf = NULL; PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); @@ -4260,7 +4260,7 @@ PerlIOBuf_get_ptr(pTHX_ PerlIO *f) { const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); return b->ptr; } @@ -4269,9 +4269,9 @@ PerlIOBuf_get_cnt(pTHX_ PerlIO *f) { const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) - return (b->end - b->ptr); + return (b->end - b->ptr); return 0; } @@ -4282,14 +4282,14 @@ PerlIOBuf_get_base(pTHX_ PerlIO *f) PERL_UNUSED_CONTEXT; if (!b->buf) { - if (!b->bufsiz) - b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ; - Newx(b->buf,b->bufsiz, STDCHAR); - if (!b->buf) { - b->buf = (STDCHAR *) & b->oneword; - b->bufsiz = sizeof(b->oneword); - } - b->end = b->ptr = b->buf; + if (!b->bufsiz) + b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ; + Newx(b->buf,b->bufsiz, STDCHAR); + if (!b->buf) { + b->buf = (STDCHAR *) & b->oneword; + b->bufsiz = sizeof(b->oneword); + } + b->end = b->ptr = b->buf; } return b->buf; } @@ -4299,7 +4299,7 @@ PerlIOBuf_bufsiz(pTHX_ PerlIO *f) { const PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); return (b->end - b->buf); } @@ -4311,7 +4311,7 @@ PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) PERL_UNUSED_ARG(cnt); #endif if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); b->ptr = ptr; assert(PerlIO_get_cnt(f) == cnt); assert(b->ptr >= b->buf); @@ -4398,8 +4398,8 @@ PerlIOPending_flush(pTHX_ PerlIO *f) { PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (b->buf && b->buf != (STDCHAR *) & b->oneword) { - Safefree(b->buf); - b->buf = NULL; + Safefree(b->buf); + b->buf = NULL; } PerlIO_pop(aTHX_ f); return 0; @@ -4409,10 +4409,10 @@ void PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) { if (cnt <= 0) { - PerlIO_flush(f); + PerlIO_flush(f); } else { - PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt); + PerlIOBuf_set_ptrcnt(aTHX_ f, ptr, cnt); } } @@ -4426,8 +4426,8 @@ PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *t * etc. get muddled when it changes mid-string when we auto-pop. */ l->flags = (l->flags & ~(PERLIO_F_FASTGETS | PERLIO_F_UTF8)) | - (PerlIOBase(PerlIONext(f))-> - flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8)); + (PerlIOBase(PerlIONext(f))-> + flags & (PERLIO_F_FASTGETS | PERLIO_F_UTF8)); return code; } @@ -4437,14 +4437,14 @@ PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) SSize_t avail = PerlIO_get_cnt(f); SSize_t got = 0; if ((SSize_t) count >= 0 && (SSize_t)count < avail) - avail = count; + avail = count; if (avail > 0) - got = PerlIOBuf_read(aTHX_ f, vbuf, avail); + got = PerlIOBuf_read(aTHX_ f, vbuf, avail); if (got >= 0 && got < (SSize_t)count) { - const SSize_t more = - PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got); - if (more >= 0 || got == 0) - got += more; + const SSize_t more = + PerlIO_read(f, ((STDCHAR *) vbuf) + got, count - got); + if (more >= 0 || got == 0) + got += more; } return got; } @@ -4500,7 +4500,7 @@ PERLIO_FUNCS_DECL(PerlIO_pending) = { typedef struct { PerlIOBuf base; /* PerlIOBuf stuff */ STDCHAR *nl; /* Position of crlf we "lied" about in the - * buffer */ + * buffer */ } PerlIOCrlf; /* Inherit the PERLIO_F_UTF8 flag from previous layer. @@ -4512,9 +4512,9 @@ S_inherit_utf8_flag(PerlIO *f) { PerlIO *g = PerlIONext(f); if (PerlIOValid(g)) { - if (PerlIOBase(g)->flags & PERLIO_F_UTF8) { - PerlIOBase(f)->flags |= PERLIO_F_UTF8; - } + if (PerlIOBase(g)->flags & PERLIO_F_UTF8) { + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + } } } @@ -4527,24 +4527,24 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) #if 0 DEBUG_i( PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n", - (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", - PerlIOBase(f)->flags); + (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", + PerlIOBase(f)->flags); ); #endif { /* If the old top layer is a CRLF layer, reactivate it (if * necessary) and remove this new layer from the stack */ - PerlIO *g = PerlIONext(f); - if (PerlIOValid(g)) { - PerlIOl *b = PerlIOBase(g); - if (b && b->tab == &PerlIO_crlf) { - if (!(b->flags & PERLIO_F_CRLF)) - b->flags |= PERLIO_F_CRLF; - S_inherit_utf8_flag(g); - PerlIO_pop(aTHX_ f); - return code; - } - } + PerlIO *g = PerlIONext(f); + if (PerlIOValid(g)) { + PerlIOl *b = PerlIOBase(g); + if (b && b->tab == &PerlIO_crlf) { + if (!(b->flags & PERLIO_F_CRLF)) + b->flags |= PERLIO_F_CRLF; + S_inherit_utf8_flag(g); + PerlIO_pop(aTHX_ f); + return code; + } + } } S_inherit_utf8_flag(f); return code; @@ -4556,52 +4556,52 @@ PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */ - *(c->nl) = NATIVE_0xd; - c->nl = NULL; + *(c->nl) = NATIVE_0xd; + c->nl = NULL; } if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) - return PerlIOBuf_unread(aTHX_ f, vbuf, count); + return PerlIOBuf_unread(aTHX_ f, vbuf, count); else { - const STDCHAR *buf = (const STDCHAR *) vbuf + count; - PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); - SSize_t unread = 0; - if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) - PerlIO_flush(f); - if (!b->buf) - PerlIO_get_base(f); - if (b->buf) { - if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { - b->end = b->ptr = b->buf + b->bufsiz; - PerlIOBase(f)->flags |= PERLIO_F_RDBUF; - b->posn -= b->bufsiz; - } - while (count > 0 && b->ptr > b->buf) { - const int ch = *--buf; - if (ch == '\n') { - if (b->ptr - 2 >= b->buf) { - *--(b->ptr) = NATIVE_0xa; - *--(b->ptr) = NATIVE_0xd; - unread++; - count--; - } - else { - /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */ + const STDCHAR *buf = (const STDCHAR *) vbuf + count; + PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); + SSize_t unread = 0; + if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) + PerlIO_flush(f); + if (!b->buf) + PerlIO_get_base(f); + if (b->buf) { + if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { + b->end = b->ptr = b->buf + b->bufsiz; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + b->posn -= b->bufsiz; + } + while (count > 0 && b->ptr > b->buf) { + const int ch = *--buf; + if (ch == '\n') { + if (b->ptr - 2 >= b->buf) { + *--(b->ptr) = NATIVE_0xa; + *--(b->ptr) = NATIVE_0xd; + unread++; + count--; + } + else { + /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */ *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa == '\r' */ - unread++; - count--; - } - } - else { - *--(b->ptr) = ch; - unread++; - count--; - } - } - } + unread++; + count--; + } + } + else { + *--(b->ptr) = ch; + unread++; + count--; + } + } + } if (count > 0) unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count); - return unread; + return unread; } } @@ -4611,69 +4611,69 @@ PerlIOCrlf_get_cnt(pTHX_ PerlIO *f) { PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { - PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); - if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) { - STDCHAR *nl = (c->nl) ? c->nl : b->ptr; - scan: - while (nl < b->end && *nl != NATIVE_0xd) - nl++; - if (nl < b->end && *nl == NATIVE_0xd) { - test: - if (nl + 1 < b->end) { - if (nl[1] == NATIVE_0xa) { - *nl = '\n'; - c->nl = nl; - } - else { - /* - * Not CR,LF but just CR - */ - nl++; - goto scan; - } - } - else { - /* - * Blast - found CR as last char in buffer - */ - - if (b->ptr < nl) { - /* - * They may not care, defer work as long as - * possible - */ - c->nl = nl; - return (nl - b->ptr); - } - else { - int code; - b->ptr++; /* say we have read it as far as - * flush() is concerned */ - b->buf++; /* Leave space in front of buffer */ - /* Note as we have moved buf up flush's - posn += ptr-buf - will naturally make posn point at CR - */ - b->bufsiz--; /* Buffer is thus smaller */ - code = PerlIO_fill(f); /* Fetch some more */ - b->bufsiz++; /* Restore size for next time */ - b->buf--; /* Point at space */ - b->ptr = nl = b->buf; /* Which is what we hand - * off */ - *nl = NATIVE_0xd; /* Fill in the CR */ - if (code == 0) - goto test; /* fill() call worked */ - /* - * CR at EOF - just fall through - */ - /* Should we clear EOF though ??? */ - } - } - } - } - return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr); + PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); + if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) { + STDCHAR *nl = (c->nl) ? c->nl : b->ptr; + scan: + while (nl < b->end && *nl != NATIVE_0xd) + nl++; + if (nl < b->end && *nl == NATIVE_0xd) { + test: + if (nl + 1 < b->end) { + if (nl[1] == NATIVE_0xa) { + *nl = '\n'; + c->nl = nl; + } + else { + /* + * Not CR,LF but just CR + */ + nl++; + goto scan; + } + } + else { + /* + * Blast - found CR as last char in buffer + */ + + if (b->ptr < nl) { + /* + * They may not care, defer work as long as + * possible + */ + c->nl = nl; + return (nl - b->ptr); + } + else { + int code; + b->ptr++; /* say we have read it as far as + * flush() is concerned */ + b->buf++; /* Leave space in front of buffer */ + /* Note as we have moved buf up flush's + posn += ptr-buf + will naturally make posn point at CR + */ + b->bufsiz--; /* Buffer is thus smaller */ + code = PerlIO_fill(f); /* Fetch some more */ + b->bufsiz++; /* Restore size for next time */ + b->buf--; /* Point at space */ + b->ptr = nl = b->buf; /* Which is what we hand + * off */ + *nl = NATIVE_0xd; /* Fill in the CR */ + if (code == 0) + goto test; /* fill() call worked */ + /* + * CR at EOF - just fall through + */ + /* Should we clear EOF though ??? */ + } + } + } + } + return (((c->nl) ? (c->nl + 1) : b->end) - b->ptr); } return 0; } @@ -4684,50 +4684,50 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); if (!b->buf) - PerlIO_get_base(f); + PerlIO_get_base(f); if (!ptr) { - if (c->nl) { - ptr = c->nl + 1; - if (ptr == b->end && *c->nl == NATIVE_0xd) { - /* Deferred CR at end of buffer case - we lied about count */ - ptr--; - } - } - else { - ptr = b->end; - } - ptr -= cnt; + if (c->nl) { + ptr = c->nl + 1; + if (ptr == b->end && *c->nl == NATIVE_0xd) { + /* Deferred CR at end of buffer case - we lied about count */ + ptr--; + } + } + else { + ptr = b->end; + } + ptr -= cnt; } else { - NOOP; + NOOP; #if 0 - /* - * Test code - delete when it works ... - */ - IV flags = PerlIOBase(f)->flags; - STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end; - if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) { - /* Deferred CR at end of buffer case - we lied about count */ - chk--; - } - chk -= cnt; - - if (ptr != chk ) { - Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf - " nl=%p e=%p for %d", (void*)ptr, (void*)chk, - flags, c->nl, b->end, cnt); - } + /* + * Test code - delete when it works ... + */ + IV flags = PerlIOBase(f)->flags; + STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end; + if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) { + /* Deferred CR at end of buffer case - we lied about count */ + chk--; + } + chk -= cnt; + + if (ptr != chk ) { + Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf + " nl=%p e=%p for %d", (void*)ptr, (void*)chk, + flags, c->nl, b->end, cnt); + } #endif } if (c->nl) { - if (ptr > c->nl) { - /* - * They have taken what we lied about - */ - *(c->nl) = NATIVE_0xd; - c->nl = NULL; - ptr++; - } + if (ptr > c->nl) { + /* + * They have taken what we lied about + */ + *(c->nl) = NATIVE_0xd; + c->nl = NULL; + ptr++; + } } b->ptr = ptr; PerlIOBase(f)->flags |= PERLIO_F_RDBUF; @@ -4737,49 +4737,49 @@ SSize_t PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) - return PerlIOBuf_write(aTHX_ f, vbuf, count); + return PerlIOBuf_write(aTHX_ f, vbuf, count); else { - PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); - const STDCHAR *buf = (const STDCHAR *) vbuf; - const STDCHAR * const ebuf = buf + count; - if (!b->buf) - PerlIO_get_base(f); - if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) - return 0; - while (buf < ebuf) { - const STDCHAR * const eptr = b->buf + b->bufsiz; - PerlIOBase(f)->flags |= PERLIO_F_WRBUF; - while (buf < ebuf && b->ptr < eptr) { - if (*buf == '\n') { - if ((b->ptr + 2) > eptr) { - /* - * Not room for both - */ - PerlIO_flush(f); - break; - } - else { - *(b->ptr)++ = NATIVE_0xd; /* CR */ - *(b->ptr)++ = NATIVE_0xa; /* LF */ - buf++; - if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { - PerlIO_flush(f); - break; - } - } - } - else { - *(b->ptr)++ = *buf++; - } - if (b->ptr >= eptr) { - PerlIO_flush(f); - break; - } - } - } - if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) - PerlIO_flush(f); - return (buf - (STDCHAR *) vbuf); + PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); + const STDCHAR *buf = (const STDCHAR *) vbuf; + const STDCHAR * const ebuf = buf + count; + if (!b->buf) + PerlIO_get_base(f); + if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) + return 0; + while (buf < ebuf) { + const STDCHAR * const eptr = b->buf + b->bufsiz; + PerlIOBase(f)->flags |= PERLIO_F_WRBUF; + while (buf < ebuf && b->ptr < eptr) { + if (*buf == '\n') { + if ((b->ptr + 2) > eptr) { + /* + * Not room for both + */ + PerlIO_flush(f); + break; + } + else { + *(b->ptr)++ = NATIVE_0xd; /* CR */ + *(b->ptr)++ = NATIVE_0xa; /* LF */ + buf++; + if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { + PerlIO_flush(f); + break; + } + } + } + else { + *(b->ptr)++ = *buf++; + } + if (b->ptr >= eptr) { + PerlIO_flush(f); + break; + } + } + } + if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) + PerlIO_flush(f); + return (buf - (STDCHAR *) vbuf); } } @@ -4788,8 +4788,8 @@ PerlIOCrlf_flush(pTHX_ PerlIO *f) { PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); if (c->nl) { - *(c->nl) = NATIVE_0xd; - c->nl = NULL; + *(c->nl) = NATIVE_0xd; + c->nl = NULL; } return PerlIOBuf_flush(aTHX_ f); } @@ -4798,11 +4798,11 @@ IV PerlIOCrlf_binmode(pTHX_ PerlIO *f) { if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) { - /* In text mode - flush any pending stuff and flip it */ - PerlIOBase(f)->flags &= ~PERLIO_F_CRLF; + /* In text mode - flush any pending stuff and flip it */ + PerlIOBase(f)->flags &= ~PERLIO_F_CRLF; #ifndef PERLIO_USING_CRLF - /* CRLF is unusual case - if this is just the :crlf layer pop it */ - PerlIO_pop(aTHX_ f); + /* CRLF is unusual case - if this is just the :crlf layer pop it */ + PerlIO_pop(aTHX_ f); #endif } return PerlIOBase_binmode(aTHX_ f); @@ -4843,7 +4843,7 @@ PerlIO * Perl_PerlIO_stdin(pTHX) { if (!PL_perlio) { - PerlIO_stdstreams(aTHX); + PerlIO_stdstreams(aTHX); } return (PerlIO*)&PL_perlio[1]; } @@ -4852,7 +4852,7 @@ PerlIO * Perl_PerlIO_stdout(pTHX) { if (!PL_perlio) { - PerlIO_stdstreams(aTHX); + PerlIO_stdstreams(aTHX); } return (PerlIO*)&PL_perlio[2]; } @@ -4861,7 +4861,7 @@ PerlIO * Perl_PerlIO_stderr(pTHX) { if (!PL_perlio) { - PerlIO_stdstreams(aTHX); + PerlIO_stdstreams(aTHX); } return (PerlIO*)&PL_perlio[3]; } @@ -4877,12 +4877,12 @@ PerlIO_getname(PerlIO *f, char *buf) bool exported = FALSE; FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; if (!stdio) { - stdio = PerlIO_exportFILE(f,0); - exported = TRUE; + stdio = PerlIO_exportFILE(f,0); + exported = TRUE; } if (stdio) { - name = fgetname(stdio, buf); - if (exported) PerlIO_releaseFILE(f,stdio); + name = fgetname(stdio, buf); + if (exported) PerlIO_releaseFILE(f,stdio); } return name; #else @@ -4933,7 +4933,7 @@ PerlIO_getc(PerlIO *f) dTHX; STDCHAR buf[1]; if ( 1 == PerlIO_read(f, buf, 1) ) { - return (unsigned char) buf[0]; + return (unsigned char) buf[0]; } return EOF; } @@ -4944,9 +4944,9 @@ PerlIO_ungetc(PerlIO *f, int ch) { dTHX; if (ch != EOF) { - STDCHAR buf = ch; - if (PerlIO_unread(f, &buf, 1) == 1) - return ch; + STDCHAR buf = ch; + if (PerlIO_unread(f, &buf, 1) == 1) + return ch; } return EOF; } @@ -5045,7 +5045,7 @@ PerlIO_tmpfile_flags(int imode) #ifdef WIN32 const int fd = win32_tmpfd_mode(imode); if (fd >= 0) - f = PerlIO_fdopen(fd, "w+b"); + f = PerlIO_fdopen(fd, "w+b"); #elif ! defined(OS2) int fd = -1; char tempname[] = "/tmp/PerlIO_XXXXXX"; @@ -5054,16 +5054,16 @@ PerlIO_tmpfile_flags(int imode) int old_umask = umask(0177); imode &= ~MKOSTEMP_MODE_MASK; if (tmpdir && *tmpdir) { - /* if TMPDIR is set and not empty, we try that first */ - sv = newSVpv(tmpdir, 0); - sv_catpv(sv, tempname + 4); - fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE); + /* if TMPDIR is set and not empty, we try that first */ + sv = newSVpv(tmpdir, 0); + sv_catpv(sv, tempname + 4); + fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE); } if (fd < 0) { - SvREFCNT_dec(sv); - sv = NULL; - /* else we try /tmp */ - fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE); + SvREFCNT_dec(sv); + sv = NULL; + /* else we try /tmp */ + fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE); } if (fd < 0) { /* Try cwd */ @@ -5078,10 +5078,10 @@ PerlIO_tmpfile_flags(int imode) int writing = 1; (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing); f = PerlIO_fdopen(fd, mode); - if (f) - PerlIOBase(f)->flags |= PERLIO_F_TEMP; + if (f) + PerlIOBase(f)->flags |= PERLIO_F_TEMP; # ifndef VMS - PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname); + PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname); # endif } SvREFCNT_dec(sv); @@ -5089,7 +5089,7 @@ PerlIO_tmpfile_flags(int imode) FILE * const stdio = PerlSIO_tmpfile(); if (stdio) - f = PerlIO_fdopen(fileno(stdio), "w+"); + f = PerlIO_fdopen(fileno(stdio), "w+"); #endif /* else WIN32 */ return f; @@ -5100,7 +5100,7 @@ Perl_PerlIO_save_errno(pTHX_ PerlIO *f) { PERL_UNUSED_CONTEXT; if (!PerlIOValid(f)) - return; + return; PerlIOBase(f)->err = errno; #ifdef VMS PerlIOBase(f)->os_err = vaxc$errno; @@ -5116,7 +5116,7 @@ Perl_PerlIO_restore_errno(pTHX_ PerlIO *f) { PERL_UNUSED_CONTEXT; if (!PerlIOValid(f)) - return; + return; SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err); #ifdef OS2 Perl_rc = PerlIOBase(f)->os_err); @@ -5144,17 +5144,17 @@ Perl_PerlIO_context_layers(pTHX_ const char *mode) */ if (!PL_curcop) - return NULL; + return NULL; if (mode && mode[0] != 'r') { - if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT) - direction = "open>"; + if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT) + direction = "open>"; } else { - if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN) - direction = "open<"; + if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN) + direction = "open<"; } if (!direction) - return NULL; + return NULL; layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0); @@ -5169,13 +5169,13 @@ int PerlIO_setpos(PerlIO *f, SV *pos) { if (SvOK(pos)) { - if (f) { - dTHX; - STRLEN len; - const Off_t * const posn = (Off_t *) SvPV(pos, len); - if(len == sizeof(Off_t)) - return PerlIO_seek(f, *posn, SEEK_SET); - } + if (f) { + dTHX; + STRLEN len; + const Off_t * const posn = (Off_t *) SvPV(pos, len); + if(len == sizeof(Off_t)) + return PerlIO_seek(f, *posn, SEEK_SET); + } } SETERRNO(EINVAL, SS_IVCHAN); return -1; @@ -5186,17 +5186,17 @@ int PerlIO_setpos(PerlIO *f, SV *pos) { if (SvOK(pos)) { - if (f) { - dTHX; - STRLEN len; - Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len); - if(len == sizeof(Fpos_t)) + if (f) { + dTHX; + STRLEN len; + Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len); + if(len == sizeof(Fpos_t)) # if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) - return fsetpos64(f, fpos); + return fsetpos64(f, fpos); # else - return fsetpos(f, fpos); + return fsetpos(f, fpos); # endif - } + } } SETERRNO(EINVAL, SS_IVCHAN); return -1; @@ -69,9 +69,9 @@ typedef PerlIOl *PerlIO; PERL_CALLCONV void PerlIO_define_layer(pTHX_ PerlIO_funcs *tab); PERL_CALLCONV PerlIO_funcs *PerlIO_find_layer(pTHX_ const char *name, STRLEN len, - int load); + int load); PERL_CALLCONV PerlIO *PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), - const char *mode, SV *arg); + const char *mode, SV *arg); PERL_CALLCONV void PerlIO_pop(pTHX_ PerlIO *f); PERL_CALLCONV AV* PerlIO_get_layers(pTHX_ PerlIO *f); PERL_CALLCONV void PerlIO_clone(pTHX_ PerlInterpreter *proto, @@ -182,8 +182,8 @@ PERL_CALLCONV PerlIO *PerlIO_open(const char *, const char *); #endif #ifndef PerlIO_openn PERL_CALLCONV PerlIO *PerlIO_openn(pTHX_ const char *layers, const char *mode, - int fd, int imode, int perm, PerlIO *old, - int narg, SV **arg); + int fd, int imode, int perm, PerlIO *old, + int narg, SV **arg); #endif #ifndef PerlIO_eof PERL_CALLCONV int PerlIO_eof(PerlIO *); @@ -308,11 +308,11 @@ PERL_CALLCONV int PerlIO_isutf8(PerlIO *); #endif #ifndef PerlIO_apply_layers PERL_CALLCONV int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, - const char *names); + const char *names); #endif #ifndef PerlIO_binmode PERL_CALLCONV int PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int omode, - const char *names); + const char *names); #endif #ifndef PerlIO_getname PERL_CALLCONV char *PerlIO_getname(PerlIO *, char *); @@ -21,10 +21,10 @@ struct _PerlIO_funcs { IV (*Pushed) (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab); IV (*Popped) (pTHX_ PerlIO *f); PerlIO *(*Open) (pTHX_ PerlIO_funcs *tab, - PerlIO_list_t *layers, IV n, - const char *mode, - int fd, int imode, int perm, - PerlIO *old, int narg, SV **args); + PerlIO_list_t *layers, IV n, + const char *mode, + int fd, int imode, int perm, + PerlIO *old, int narg, SV **args); IV (*Binmode)(pTHX_ PerlIO *f); SV *(*Getarg) (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags); IV (*Fileno) (pTHX_ PerlIO *f); @@ -144,7 +144,7 @@ typedef struct { } PerlIOBuf; PERL_CALLCONV int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, - PerlIO_list_t *layers, IV n, IV max); + PerlIO_list_t *layers, IV n, IV max); PERL_CALLCONV int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names); PERL_CALLCONV PerlIO_funcs *PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def); diff --git a/perlvars.h b/perlvars.h index 3bfd46fe94..0518c0fe4a 100644 --- a/perlvars.h +++ b/perlvars.h @@ -38,9 +38,9 @@ use the variable. PERLVAR(G, op_mutex, perl_mutex) /* Mutex for op refcounting */ #endif PERLVARI(G, curinterp, PerlInterpreter *, NULL) - /* currently running interpreter - * (initial parent interpreter under - * useithreads) */ + /* currently running interpreter + * (initial parent interpreter under + * useithreads) */ #if defined(USE_ITHREADS) PERLVAR(G, thr_key, perl_key) /* key to retrieve per-thread struct */ #endif @@ -57,7 +57,7 @@ PERLVARI(G, sig_handlers_initted, int, 0) #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PERLVARA(G, sig_ignoring, SIG_SIZE, int) - /* which signals we are ignoring */ + /* which signals we are ignoring */ #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PERLVARA(G, sig_defaulting, SIG_SIZE, int) @@ -190,9 +190,9 @@ PERLVARI(G, veto_cleanup, int, FALSE) /* exit without cleanup */ Function pointer, pointing at a function used to handle extended keywords. The function should be declared as - int keyword_plugin_function(pTHX_ - char *keyword_ptr, STRLEN keyword_len, - OP **op_ptr) + int keyword_plugin_function(pTHX_ + char *keyword_ptr, STRLEN keyword_len, + OP **op_ptr) The function is called from the tokeniser, whenever a possible keyword is seen. C<keyword_ptr> points at the word in the parser's input @@ -93,15 +93,15 @@ typedef signed char yysigned_char; # define YYDPRINTF(Args) \ do { \ if (yydebug) \ - YYFPRINTF Args; \ + YYFPRINTF Args; \ } while (0) # define YYDSYMPRINTF(Title, Token, Value) \ do { \ if (yydebug) { \ - YYFPRINTF (Perl_debug_log, "%s ", Title); \ - yysymprint (aTHX_ Perl_debug_log, Token, Value); \ - YYFPRINTF (Perl_debug_log, "\n"); \ + YYFPRINTF (Perl_debug_log, "%s ", Title); \ + yysymprint (aTHX_ Perl_debug_log, Token, Value); \ + YYFPRINTF (Perl_debug_log, "\n"); \ } \ } while (0) @@ -114,15 +114,15 @@ yysymprint(pTHX_ PerlIO * const yyoutput, int yytype, const YYSTYPE * const yyva { PERL_UNUSED_CONTEXT; if (yytype < YYNTOKENS) { - YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); + YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); # ifdef YYPRINT - YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); + YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); # else - YYFPRINTF (yyoutput, "0x%" UVxf, (UV)yyvaluep->ival); + YYFPRINTF (yyoutput, "0x%" UVxf, (UV)yyvaluep->ival); # endif } else - YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); + YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); YYFPRINTF (yyoutput, ")"); } @@ -139,36 +139,36 @@ yy_stack_print (pTHX_ const yy_parser *parser) min = parser->ps - 8 + 1; if (min <= parser->stack) - min = parser->stack + 1; + min = parser->stack + 1; PerlIO_printf(Perl_debug_log, "\nindex:"); for (ps = min; ps <= parser->ps; ps++) - PerlIO_printf(Perl_debug_log, " %8d", (int)(ps - parser->stack)); + PerlIO_printf(Perl_debug_log, " %8d", (int)(ps - parser->stack)); PerlIO_printf(Perl_debug_log, "\nstate:"); for (ps = min; ps <= parser->ps; ps++) - PerlIO_printf(Perl_debug_log, " %8d", ps->state); + PerlIO_printf(Perl_debug_log, " %8d", ps->state); PerlIO_printf(Perl_debug_log, "\ntoken:"); for (ps = min; ps <= parser->ps; ps++) - PerlIO_printf(Perl_debug_log, " %8.8s", ps->name); + PerlIO_printf(Perl_debug_log, " %8.8s", ps->name); PerlIO_printf(Perl_debug_log, "\nvalue:"); for (ps = min; ps <= parser->ps; ps++) { - switch (yy_type_tab[yystos[ps->state]]) { - case toketype_opval: - PerlIO_printf(Perl_debug_log, " %8.8s", - ps->val.opval - ? PL_op_name[ps->val.opval->op_type] - : "(Nullop)" - ); - break; - case toketype_ival: - PerlIO_printf(Perl_debug_log, " %8" IVdf, (IV)ps->val.ival); - break; - default: - PerlIO_printf(Perl_debug_log, " %8" UVxf, (UV)ps->val.ival); - } + switch (yy_type_tab[yystos[ps->state]]) { + case toketype_opval: + PerlIO_printf(Perl_debug_log, " %8.8s", + ps->val.opval + ? PL_op_name[ps->val.opval->op_type] + : "(Nullop)" + ); + break; + case toketype_ival: + PerlIO_printf(Perl_debug_log, " %8" IVdf, (IV)ps->val.ival); + break; + default: + PerlIO_printf(Perl_debug_log, " %8" UVxf, (UV)ps->val.ival); + } } PerlIO_printf(Perl_debug_log, "\n\n"); } @@ -176,7 +176,7 @@ yy_stack_print (pTHX_ const yy_parser *parser) # define YY_STACK_PRINT(parser) \ do { \ if (yydebug && DEBUG_v_TEST) \ - yy_stack_print (aTHX_ parser); \ + yy_stack_print (aTHX_ parser); \ } while (0) @@ -190,15 +190,15 @@ yy_reduce_print (pTHX_ int yyrule) int yyi; const unsigned int yylineno = yyrline[yyrule]; YYFPRINTF (Perl_debug_log, "Reducing stack by rule %d (line %u), ", - yyrule - 1, yylineno); + yyrule - 1, yylineno); /* Print the symbols being reduced, and their result. */ #if PERL_BISON_VERSION >= 30000 /* 3.0+ */ for (yyi = 0; yyi < yyr2[yyrule]; yyi++) - YYFPRINTF (Perl_debug_log, "%s ", + YYFPRINTF (Perl_debug_log, "%s ", yytname [yystos[(PL_parser->ps)[yyi + 1 - yyr2[yyrule]].state]]); #else for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++) - YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]); + YYFPRINTF (Perl_debug_log, "%s ", yytname [yyrhs[yyi]]); #endif YYFPRINTF (Perl_debug_log, "-> %s\n", yytname [yyr1[yyrule]]); } @@ -206,7 +206,7 @@ yy_reduce_print (pTHX_ int yyrule) # define YY_REDUCE_PRINT(Rule) \ do { \ if (yydebug) \ - yy_reduce_print (aTHX_ Rule); \ + yy_reduce_print (aTHX_ Rule); \ } while (0) #else /* !DEBUGGING */ @@ -226,32 +226,32 @@ S_clear_yystack(pTHX_ const yy_parser *parser) int i = 0; if (!parser->stack) - return; + return; YYDPRINTF ((Perl_debug_log, "clearing the parse stack\n")); for (i=0; i< parser->yylen; i++) { - SvREFCNT_dec(ps[-i].compcv); + SvREFCNT_dec(ps[-i].compcv); } ps -= parser->yylen; /* now free whole the stack, including the just-reduced ops */ while (ps > parser->stack) { - LEAVE_SCOPE(ps->savestack_ix); - if (yy_type_tab[yystos[ps->state]] == toketype_opval - && ps->val.opval) - { - if (ps->compcv && (ps->compcv != PL_compcv)) { - PL_compcv = ps->compcv; - PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); - PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); - } - YYDPRINTF ((Perl_debug_log, "(freeing op)\n")); - op_free(ps->val.opval); - } - SvREFCNT_dec(ps->compcv); - ps--; + LEAVE_SCOPE(ps->savestack_ix); + if (yy_type_tab[yystos[ps->state]] == toketype_opval + && ps->val.opval) + { + if (ps->compcv && (ps->compcv != PL_compcv)) { + PL_compcv = ps->compcv; + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_compcv), 1); + PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); + } + YYDPRINTF ((Perl_debug_log, "(freeing op)\n")); + op_free(ps->val.opval); + } + SvREFCNT_dec(ps->compcv); + ps--; } Safefree(parser->stack); @@ -279,7 +279,7 @@ Perl_yyparse (pTHX_ int gramtype) #define YYPUSHSTACK parser->ps = ++ps /* The variable used to return semantic value and location from the - action routines: ie $$. */ + action routines: ie $$. */ YYSTYPE yyval; YYDPRINTF ((Perl_debug_log, "Starting parse\n")); @@ -592,7 +592,7 @@ Perl_yyparse (pTHX_ int gramtype) yyacceptlab: yyresult = 0; for (ps=parser->ps; ps > parser->stack; ps--) { - SvREFCNT_dec(ps->compcv); + SvREFCNT_dec(ps->compcv); } parser->ps = parser->stack; /* disable cleanup */ goto yyreturn; diff --git a/plan9/plan9.c b/plan9/plan9.c index 02ef76c97b..9872306d7e 100644 --- a/plan9/plan9.c +++ b/plan9/plan9.c @@ -11,18 +11,18 @@ #define SHIFT 20 int fpclassify(double d) { - FPdbleword x; - - /* order matters: only isNaN can operate on NaN */ - if ( isNaN(d) ) - return FP_NAN; - else if ( isInf(d, 0) ) - return FP_INFINITE; - else if ( d == 0 ) - return FP_ZERO; - - x.x = fabs(d); - return (x.hi >> SHIFT) ? FP_NORMAL : FP_SUBNORMAL; + FPdbleword x; + + /* order matters: only isNaN can operate on NaN */ + if ( isNaN(d) ) + return FP_NAN; + else if ( isInf(d, 0) ) + return FP_INFINITE; + else if ( d == 0 ) + return FP_ZERO; + + x.x = fabs(d); + return (x.hi >> SHIFT) ? FP_NORMAL : FP_SUBNORMAL; } /* Functions mentioned in /sys/include/ape/sys/socket.h but not implemented */ diff --git a/plan9/plan9ish.h b/plan9/plan9ish.h index 7fd8c7e5db..a5a318e704 100644 --- a/plan9/plan9ish.h +++ b/plan9/plan9ish.h @@ -105,7 +105,7 @@ #define BIT_BUCKET "/dev/null" #define PERL_SYS_INIT_BODY(c,v) \ - MALLOC_CHECK_TAINT2(*c,*v) PERLIO_INIT; MALLOC_INIT + MALLOC_CHECK_TAINT2(*c,*v) PERLIO_INIT; MALLOC_INIT #define dXSUB_SYS dNOOP #define PERL_SYS_TERM_BODY() PERLIO_TERM; MALLOC_TERM @@ -70,7 +70,7 @@ value for the OP, but some use it for other purposes. I32 * mark_stack_entry; \ if (UNLIKELY((mark_stack_entry = ++PL_markstack_ptr) \ == PL_markstack_max)) \ - mark_stack_entry = markstack_grow(); \ + mark_stack_entry = markstack_grow(); \ *mark_stack_entry = (I32)((p) - PL_stack_base); \ DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log, \ "MARK push %p %" IVdf "\n", \ @@ -520,7 +520,7 @@ Does not use C<TARG>. See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>. #define dPOPXiirl(X) IV right = POPi; IV left = CAT2(X,i) #define USE_LEFT(sv) \ - (SvOK(sv) || !(PL_op->op_flags & OPf_STACKED)) + (SvOK(sv) || !(PL_op->op_flags & OPf_STACKED)) #define dPOPXiirl_ul_nomg(X) \ IV right = (sp--, SvIV_nomg(TOPp1s)); \ SV *leftsv = CAT2(X,s); \ @@ -554,18 +554,18 @@ Does not use C<TARG>. See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>. #define SWITCHSTACK(f,t) \ STMT_START { \ - AvFILLp(f) = sp - PL_stack_base; \ - PL_stack_base = AvARRAY(t); \ - PL_stack_max = PL_stack_base + AvMAX(t); \ - sp = PL_stack_sp = PL_stack_base + AvFILLp(t); \ - PL_curstack = t; \ + AvFILLp(f) = sp - PL_stack_base; \ + PL_stack_base = AvARRAY(t); \ + PL_stack_max = PL_stack_base + AvMAX(t); \ + sp = PL_stack_sp = PL_stack_base + AvFILLp(t); \ + PL_curstack = t; \ } STMT_END #define EXTEND_MORTAL(n) \ STMT_START { \ - SSize_t eMiX = PL_tmps_ix + (n); \ - if (UNLIKELY(eMiX >= PL_tmps_max)) \ - (void)Perl_tmps_grow_p(aTHX_ eMiX); \ + SSize_t eMiX = PL_tmps_ix + (n); \ + if (UNLIKELY(eMiX >= PL_tmps_max)) \ + (void)Perl_tmps_grow_p(aTHX_ eMiX); \ } STMT_END #define AMGf_noright 1 @@ -581,14 +581,14 @@ Does not use C<TARG>. See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>. /* do SvGETMAGIC on the stack args before checking for overload */ #define tryAMAGICun_MG(method, flags) STMT_START { \ - if ( UNLIKELY((SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG))) \ - && Perl_try_amagic_un(aTHX_ method, flags)) \ - return NORMAL; \ + if ( UNLIKELY((SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG))) \ + && Perl_try_amagic_un(aTHX_ method, flags)) \ + return NORMAL; \ } STMT_END #define tryAMAGICbin_MG(method, flags) STMT_START { \ - if ( UNLIKELY(((SvFLAGS(TOPm1s)|SvFLAGS(TOPs)) & (SVf_ROK|SVs_GMG))) \ - && Perl_try_amagic_bin(aTHX_ method, flags)) \ - return NORMAL; \ + if ( UNLIKELY(((SvFLAGS(TOPm1s)|SvFLAGS(TOPs)) & (SVf_ROK|SVs_GMG))) \ + && Perl_try_amagic_bin(aTHX_ method, flags)) \ + return NORMAL; \ } STMT_END #define AMG_CALLunary(sv,meth) \ @@ -599,16 +599,16 @@ Does not use C<TARG>. See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>. #define tryAMAGICunTARGETlist(meth, jump) \ STMT_START { \ - dSP; \ - SV *tmpsv; \ - SV *arg= *sp; \ + dSP; \ + SV *tmpsv; \ + SV *arg= *sp; \ U8 gimme = GIMME_V; \ - if (UNLIKELY(SvAMAGIC(arg) && \ - (tmpsv = amagic_call(arg, &PL_sv_undef, meth, \ - AMGf_want_list | AMGf_noright \ - |AMGf_unary)))) \ + if (UNLIKELY(SvAMAGIC(arg) && \ + (tmpsv = amagic_call(arg, &PL_sv_undef, meth, \ + AMGf_want_list | AMGf_noright \ + |AMGf_unary)))) \ { \ - SPAGAIN; \ + SPAGAIN; \ if (gimme == G_VOID) { \ NOOP; \ } \ @@ -629,25 +629,25 @@ Does not use C<TARG>. See also C<L</XPUSHu>>, C<L</mPUSHu>> and C<L</PUSHu>>. sp--; \ SETTARG; \ } \ - PUTBACK; \ - if (jump) { \ - OP *jump_o = NORMAL->op_next; \ - while (jump_o->op_type == OP_NULL) \ - jump_o = jump_o->op_next; \ - assert(jump_o->op_type == OP_ENTERSUB); \ - (void)POPMARK; \ - return jump_o->op_next; \ - } \ - return NORMAL; \ - } \ + PUTBACK; \ + if (jump) { \ + OP *jump_o = NORMAL->op_next; \ + while (jump_o->op_type == OP_NULL) \ + jump_o = jump_o->op_next; \ + assert(jump_o->op_type == OP_ENTERSUB); \ + (void)POPMARK; \ + return jump_o->op_next; \ + } \ + return NORMAL; \ + } \ } STMT_END /* This is no longer used anywhere in the core. You might wish to consider calling amagic_deref_call() directly, as it has a cleaner interface. */ #define tryAMAGICunDEREF(meth) \ STMT_START { \ - sv = amagic_deref_call(*sp, CAT2(meth,_amg)); \ - SPAGAIN; \ + sv = amagic_deref_call(*sp, CAT2(meth,_amg)); \ + SPAGAIN; \ } STMT_END @@ -682,13 +682,13 @@ True if this op will be the return value of an lvalue subroutine /* Used in various places that need to dereference a glob or globref */ # define MAYBE_DEREF_GV_flags(sv,phlags) \ ( \ - (void)(phlags & SV_GMAGIC && (SvGETMAGIC(sv),0)), \ - isGV_with_GP(sv) \ - ? (GV *)(sv) \ - : SvROK(sv) && SvTYPE(SvRV(sv)) <= SVt_PVLV && \ - (SvGETMAGIC(SvRV(sv)), isGV_with_GP(SvRV(sv))) \ - ? (GV *)SvRV(sv) \ - : NULL \ + (void)(phlags & SV_GMAGIC && (SvGETMAGIC(sv),0)), \ + isGV_with_GP(sv) \ + ? (GV *)(sv) \ + : SvROK(sv) && SvTYPE(SvRV(sv)) <= SVt_PVLV && \ + (SvGETMAGIC(SvRV(sv)), isGV_with_GP(SvRV(sv))) \ + ? (GV *)SvRV(sv) \ + : NULL \ ) # define MAYBE_DEREF_GV(sv) MAYBE_DEREF_GV_flags(sv,SV_GMAGIC) # define MAYBE_DEREF_GV_nomg(sv) MAYBE_DEREF_GV_flags(sv,0) @@ -53,22 +53,22 @@ PP(pp_wantarray) EXTEND(SP, 1); if (PL_op->op_private & OPpOFFBYONE) { - if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF; + if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF; } else { cxix = dopopto_cursub(); if (cxix < 0) - RETPUSHUNDEF; + RETPUSHUNDEF; cx = &cxstack[cxix]; } switch (cx->blk_gimme) { case G_ARRAY: - RETPUSHYES; + RETPUSHYES; case G_SCALAR: - RETPUSHNO; + RETPUSHNO; default: - RETPUSHUNDEF; + RETPUSHUNDEF; } } @@ -90,20 +90,20 @@ PP(pp_regcomp) bool is_bare_re= FALSE; if (PL_op->op_flags & OPf_STACKED) { - dMARK; - nargs = SP - MARK; - args = ++MARK; + dMARK; + nargs = SP - MARK; + args = ++MARK; } else { - nargs = 1; - args = SP; + nargs = 1; + args = SP; } /* prevent recompiling under /o and ithreads. */ #if defined(USE_ITHREADS) if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) { - SP = args-1; - RETURN; + SP = args-1; + RETURN; } #endif @@ -112,57 +112,57 @@ PP(pp_regcomp) eng = re ? RX_ENGINE(re) : current_re_engine(); new_re = (eng->op_comp - ? eng->op_comp - : &Perl_re_op_compile - )(aTHX_ args, nargs, pm->op_code_list, eng, re, - &is_bare_re, + ? eng->op_comp + : &Perl_re_op_compile + )(aTHX_ args, nargs, pm->op_code_list, eng, re, + &is_bare_re, (pm->op_pmflags & RXf_PMf_FLAGCOPYMASK), - pm->op_pmflags | - (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0)); + pm->op_pmflags | + (PL_op->op_flags & OPf_SPECIAL ? PMf_USE_RE_EVAL : 0)); if (pm->op_pmflags & PMf_HAS_CV) - ReANY(new_re)->qr_anoncv - = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ)); + ReANY(new_re)->qr_anoncv + = (CV*) SvREFCNT_inc(PAD_SV(PL_op->op_targ)); if (is_bare_re) { - REGEXP *tmp; - /* The match's LHS's get-magic might need to access this op's regexp - (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call - get-magic now before we replace the regexp. Hopefully this hack can - be replaced with the approach described at - http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html - some day. */ - if (pm->op_type == OP_MATCH) { - SV *lhs; - const bool was_tainted = TAINT_get; - if (pm->op_flags & OPf_STACKED) - lhs = args[-1]; - else if (pm->op_targ) - lhs = PAD_SV(pm->op_targ); - else lhs = DEFSV; - SvGETMAGIC(lhs); - /* Restore the previous value of PL_tainted (which may have been - modified by get-magic), to avoid incorrectly setting the - RXf_TAINTED flag with RX_TAINT_on further down. */ - TAINT_set(was_tainted); + REGEXP *tmp; + /* The match's LHS's get-magic might need to access this op's regexp + (e.g. $' =~ /$re/ while foo; see bug 70764). So we must call + get-magic now before we replace the regexp. Hopefully this hack can + be replaced with the approach described at + http://www.nntp.perl.org/group/perl.perl5.porters/2007/03/msg122415.html + some day. */ + if (pm->op_type == OP_MATCH) { + SV *lhs; + const bool was_tainted = TAINT_get; + if (pm->op_flags & OPf_STACKED) + lhs = args[-1]; + else if (pm->op_targ) + lhs = PAD_SV(pm->op_targ); + else lhs = DEFSV; + SvGETMAGIC(lhs); + /* Restore the previous value of PL_tainted (which may have been + modified by get-magic), to avoid incorrectly setting the + RXf_TAINTED flag with RX_TAINT_on further down. */ + TAINT_set(was_tainted); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(was_tainted); #endif - } - tmp = reg_temp_copy(NULL, new_re); - ReREFCNT_dec(new_re); - new_re = tmp; + } + tmp = reg_temp_copy(NULL, new_re); + ReREFCNT_dec(new_re); + new_re = tmp; } if (re != new_re) { - ReREFCNT_dec(re); - PM_SETRE(pm, new_re); + ReREFCNT_dec(re); + PM_SETRE(pm, new_re); } assert(TAINTING_get || !TAINT_get); if (TAINT_get) { - SvTAINTED_on((SV*)new_re); + SvTAINTED_on((SV*)new_re); RX_TAINT_on(new_re); } @@ -179,7 +179,7 @@ PP(pp_regcomp) /* can't change the optree at runtime either */ /* PMf_KEEP is handled differently under threads to avoid these problems */ if (pm->op_pmflags & PMf_KEEP) { - cLOGOP->op_first->op_next = PL_op->op_next; + cLOGOP->op_first->op_next = PL_op->op_next; } #endif @@ -204,82 +204,82 @@ PP(pp_substcont) PERL_ASYNC_CHECK(); if(old != rx) { - if(old) - ReREFCNT_dec(old); - PM_SETRE(pm,ReREFCNT_inc(rx)); + if(old) + ReREFCNT_dec(old); + PM_SETRE(pm,ReREFCNT_inc(rx)); } rxres_restore(&cx->sb_rxres, rx); if (cx->sb_iters++) { - const SSize_t saviters = cx->sb_iters; - if (cx->sb_iters > cx->sb_maxiters) - DIE(aTHX_ "Substitution loop"); + const SSize_t saviters = cx->sb_iters; + if (cx->sb_iters > cx->sb_maxiters) + DIE(aTHX_ "Substitution loop"); - SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */ + SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */ - /* See "how taint works" above pp_subst() */ - sv_catsv_nomg(dstr, POPs); - if (UNLIKELY(TAINT_get)) - cx->sb_rxtainted |= SUBST_TAINT_REPL; - if (CxONCE(cx) || s < orig || + /* See "how taint works" above pp_subst() */ + sv_catsv_nomg(dstr, POPs); + if (UNLIKELY(TAINT_get)) + cx->sb_rxtainted |= SUBST_TAINT_REPL; + if (CxONCE(cx) || s < orig || !CALLREGEXEC(rx, s, cx->sb_strend, orig, - (s == m), cx->sb_targ, NULL, + (s == m), cx->sb_targ, NULL, (REXEC_IGNOREPOS|REXEC_NOT_FIRST|REXEC_FAIL_ON_UNDERFLOW))) - { - SV *targ = cx->sb_targ; - - assert(cx->sb_strend >= s); - if(cx->sb_strend > s) { - if (DO_UTF8(dstr) && !SvUTF8(targ)) - sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); - else - sv_catpvn_nomg(dstr, s, cx->sb_strend - s); - } - if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ - cx->sb_rxtainted |= SUBST_TAINT_PAT; - - if (pm->op_pmflags & PMf_NONDESTRUCT) { - PUSHs(dstr); - /* From here on down we're using the copy, and leaving the - original untouched. */ - targ = dstr; - } - else { - SV_CHECK_THINKFIRST_COW_DROP(targ); - if (isGV(targ)) Perl_croak_no_modify(); - SvPV_free(targ); - SvPV_set(targ, SvPVX(dstr)); - SvCUR_set(targ, SvCUR(dstr)); - SvLEN_set(targ, SvLEN(dstr)); - if (DO_UTF8(dstr)) - SvUTF8_on(targ); - SvPV_set(dstr, NULL); - - PL_tainted = 0; - mPUSHi(saviters - 1); - - (void)SvPOK_only_UTF8(targ); - } - - /* update the taint state of various variables in - * preparation for final exit. - * See "how taint works" above pp_subst() */ - if (TAINTING_get) { - if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || - ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) - == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) - ) - (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ - - if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET) - && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) - ) - SvTAINTED_on(TOPs); /* taint return value */ - /* needed for mg_set below */ - TAINT_set( + { + SV *targ = cx->sb_targ; + + assert(cx->sb_strend >= s); + if(cx->sb_strend > s) { + if (DO_UTF8(dstr) && !SvUTF8(targ)) + sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv); + else + sv_catpvn_nomg(dstr, s, cx->sb_strend - s); + } + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + cx->sb_rxtainted |= SUBST_TAINT_PAT; + + if (pm->op_pmflags & PMf_NONDESTRUCT) { + PUSHs(dstr); + /* From here on down we're using the copy, and leaving the + original untouched. */ + targ = dstr; + } + else { + SV_CHECK_THINKFIRST_COW_DROP(targ); + if (isGV(targ)) Perl_croak_no_modify(); + SvPV_free(targ); + SvPV_set(targ, SvPVX(dstr)); + SvCUR_set(targ, SvCUR(dstr)); + SvLEN_set(targ, SvLEN(dstr)); + if (DO_UTF8(dstr)) + SvUTF8_on(targ); + SvPV_set(dstr, NULL); + + PL_tainted = 0; + mPUSHi(saviters - 1); + + (void)SvPOK_only_UTF8(targ); + } + + /* update the taint state of various variables in + * preparation for final exit. + * See "how taint works" above pp_subst() */ + if (TAINTING_get) { + if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || + ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ + + if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET) + && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) + ) + SvTAINTED_on(TOPs); /* taint return value */ + /* needed for mg_set below */ + TAINT_set( cBOOL(cx->sb_rxtainted & - (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) + (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) ); /* sv_magic(), when adding magic (e.g.taint magic), also @@ -299,42 +299,42 @@ PP(pp_substcont) } } - SvTAINT(TARG); - } - /* PL_tainted must be correctly set for this mg_set */ - SvSETMAGIC(TARG); - TAINT_NOT; + SvTAINT(TARG); + } + /* PL_tainted must be correctly set for this mg_set */ + SvSETMAGIC(TARG); + TAINT_NOT; - CX_LEAVE_SCOPE(cx); - CX_POPSUBST(cx); + CX_LEAVE_SCOPE(cx); + CX_POPSUBST(cx); CX_POP(cx); - PERL_ASYNC_CHECK(); - RETURNOP(pm->op_next); - NOT_REACHED; /* NOTREACHED */ - } - cx->sb_iters = saviters; + PERL_ASYNC_CHECK(); + RETURNOP(pm->op_next); + NOT_REACHED; /* NOTREACHED */ + } + cx->sb_iters = saviters; } if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { - m = s; - s = orig; + m = s; + s = orig; assert(!RX_SUBOFFSET(rx)); - cx->sb_orig = orig = RX_SUBBEG(rx); - s = orig + (m - s); - cx->sb_strend = s + (cx->sb_strend - m); + cx->sb_orig = orig = RX_SUBBEG(rx); + s = orig + (m - s); + cx->sb_strend = s + (cx->sb_strend - m); } cx->sb_m = m = RX_OFFS(rx)[0].start + orig; if (m > s) { - if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) - sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv); - else - sv_catpvn_nomg(dstr, s, m-s); + if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) + sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv); + else + sv_catpvn_nomg(dstr, s, m-s); } cx->sb_s = RX_OFFS(rx)[0].end + orig; { /* Update the pos() information. */ - SV * const sv - = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ; - MAGIC *mg; + SV * const sv + = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ; + MAGIC *mg; /* the string being matched against may no longer be a string, * e.g. $_=0; s/.../$_++/ge */ @@ -342,31 +342,31 @@ PP(pp_substcont) if (!SvPOK(sv)) SvPV_force_nomg_nolen(sv); - if (!(mg = mg_find_mglob(sv))) { - mg = sv_magicext_mglob(sv); - } - MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig); + if (!(mg = mg_find_mglob(sv))) { + mg = sv_magicext_mglob(sv); + } + MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig); } if (old != rx) - (void)ReREFCNT_inc(rx); + (void)ReREFCNT_inc(rx); /* update the taint state of various variables in preparation * for calling the code block. * See "how taint works" above pp_subst() */ if (TAINTING_get) { - if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ - cx->sb_rxtainted |= SUBST_TAINT_PAT; + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + cx->sb_rxtainted |= SUBST_TAINT_PAT; - if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || - ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) - == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) - ) - (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ + if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || + ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ - if (cx->sb_iters > 1 && (cx->sb_rxtainted & - (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))) - SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT) - ? cx->sb_dstr : cx->sb_targ); - TAINT_NOT; + if (cx->sb_iters > 1 && (cx->sb_rxtainted & + (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))) + SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT) + ? cx->sb_dstr : cx->sb_targ); + TAINT_NOT; } rxres_save(&cx->sb_rxres, rx); PL_curpm = pm; @@ -384,15 +384,15 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) if (!p || p[1] < RX_NPARENS(rx)) { #ifdef PERL_ANY_COW - i = 7 + (RX_NPARENS(rx)+1) * 2; + i = 7 + (RX_NPARENS(rx)+1) * 2; #else - i = 6 + (RX_NPARENS(rx)+1) * 2; + i = 6 + (RX_NPARENS(rx)+1) * 2; #endif - if (!p) - Newx(p, i, UV); - else - Renew(p, i, UV); - *rsp = (void*)p; + if (!p) + Newx(p, i, UV); + else + Renew(p, i, UV); + *rsp = (void*)p; } /* what (if anything) to free on croak */ @@ -410,8 +410,8 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *p++ = (UV)RX_SUBOFFSET(rx); *p++ = (UV)RX_SUBCOFFSET(rx); for (i = 0; i <= RX_NPARENS(rx); ++i) { - *p++ = (UV)RX_OFFS(rx)[i].start; - *p++ = (UV)RX_OFFS(rx)[i].end; + *p++ = (UV)RX_OFFS(rx)[i].start; + *p++ = (UV)RX_OFFS(rx)[i].end; } } @@ -431,7 +431,7 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) #ifdef PERL_ANY_COW if (RX_SAVED_COPY(rx)) - SvREFCNT_dec (RX_SAVED_COPY(rx)); + SvREFCNT_dec (RX_SAVED_COPY(rx)); RX_SAVED_COPY(rx) = INT2PTR(SV*,*p); *p++ = 0; #endif @@ -441,8 +441,8 @@ S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) RX_SUBOFFSET(rx) = (I32)*p++; RX_SUBCOFFSET(rx) = (I32)*p++; for (i = 0; i <= RX_NPARENS(rx); ++i) { - RX_OFFS(rx)[i].start = (I32)(*p++); - RX_OFFS(rx)[i].end = (I32)(*p++); + RX_OFFS(rx)[i].start = (I32)(*p++); + RX_OFFS(rx)[i].end = (I32)(*p++); } } @@ -455,12 +455,12 @@ S_rxres_free(pTHX_ void **rsp) PERL_UNUSED_CONTEXT; if (p) { - void *tmp = INT2PTR(char*,*p); + void *tmp = INT2PTR(char*,*p); #ifdef PERL_POISON #ifdef PERL_ANY_COW - U32 i = 9 + p[1] * 2; + U32 i = 9 + p[1] * 2; #else - U32 i = 8 + p[1] * 2; + U32 i = 8 + p[1] * 2; #endif #endif @@ -471,9 +471,9 @@ S_rxres_free(pTHX_ void **rsp) PoisonFree(p, i, sizeof(UV)); #endif - Safefree(tmp); - Safefree(p); - *rsp = NULL; + Safefree(tmp); + Safefree(p); + *rsp = NULL; } } @@ -521,9 +521,9 @@ PP(pp_formline) SvPV_force(PL_formtarget, len); if (SvTAINTED(tmpForm) || SvTAINTED(formsv)) - SvTAINTED_on(PL_formtarget); + SvTAINTED_on(PL_formtarget); if (DO_UTF8(PL_formtarget)) - targ_is_utf8 = TRUE; + targ_is_utf8 = TRUE; /* this is an initial estimate of how much output buffer space * to allocate. It may be exceeded later */ linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1); @@ -533,76 +533,76 @@ PP(pp_formline) f = SvPV_const(formsv, len); for (;;) { - DEBUG_f( { - const char *name = "???"; - arg = -1; - switch (*fpc) { - case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; - case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; - case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; - case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; - case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; - - case FF_CHECKNL: name = "CHECKNL"; break; - case FF_CHECKCHOP: name = "CHECKCHOP"; break; - case FF_SPACE: name = "SPACE"; break; - case FF_HALFSPACE: name = "HALFSPACE"; break; - case FF_ITEM: name = "ITEM"; break; - case FF_CHOP: name = "CHOP"; break; - case FF_LINEGLOB: name = "LINEGLOB"; break; - case FF_NEWLINE: name = "NEWLINE"; break; - case FF_MORE: name = "MORE"; break; - case FF_LINEMARK: name = "LINEMARK"; break; - case FF_END: name = "END"; break; - case FF_0DECIMAL: name = "0DECIMAL"; break; - case FF_LINESNGL: name = "LINESNGL"; break; - } - if (arg >= 0) - PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); - else - PerlIO_printf(Perl_debug_log, "%-16s\n", name); - } ); - switch (*fpc++) { - case FF_LINEMARK: /* start (or end) of a line */ - linemark = t - SvPVX(PL_formtarget); - lines++; - gotsome = FALSE; - break; - - case FF_LITERAL: /* append <arg> literal chars */ - to_copy = *fpc++; - source = (U8 *)f; - f += to_copy; - trans = '~'; - item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv); - goto append; - - case FF_SKIP: /* skip <arg> chars in format */ - f += *fpc++; - break; - - case FF_FETCH: /* get next item and set field size to <arg> */ - arg = *fpc++; - f += arg; - fieldsize = arg; - - if (MARK < SP) - sv = *++MARK; - else { - sv = &PL_sv_no; - Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); - } - if (SvTAINTED(sv)) - SvTAINTED_on(PL_formtarget); - break; - - case FF_CHECKNL: /* find max len of item (up to \n) that fits field */ - { - const char *s = item = SvPV_const(sv, len); - const char *send = s + len; + DEBUG_f( { + const char *name = "???"; + arg = -1; + switch (*fpc) { + case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break; + case FF_BLANK: arg = fpc[1]; name = "BLANK"; break; + case FF_SKIP: arg = fpc[1]; name = "SKIP"; break; + case FF_FETCH: arg = fpc[1]; name = "FETCH"; break; + case FF_DECIMAL: arg = fpc[1]; name = "DECIMAL"; break; + + case FF_CHECKNL: name = "CHECKNL"; break; + case FF_CHECKCHOP: name = "CHECKCHOP"; break; + case FF_SPACE: name = "SPACE"; break; + case FF_HALFSPACE: name = "HALFSPACE"; break; + case FF_ITEM: name = "ITEM"; break; + case FF_CHOP: name = "CHOP"; break; + case FF_LINEGLOB: name = "LINEGLOB"; break; + case FF_NEWLINE: name = "NEWLINE"; break; + case FF_MORE: name = "MORE"; break; + case FF_LINEMARK: name = "LINEMARK"; break; + case FF_END: name = "END"; break; + case FF_0DECIMAL: name = "0DECIMAL"; break; + case FF_LINESNGL: name = "LINESNGL"; break; + } + if (arg >= 0) + PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg); + else + PerlIO_printf(Perl_debug_log, "%-16s\n", name); + } ); + switch (*fpc++) { + case FF_LINEMARK: /* start (or end) of a line */ + linemark = t - SvPVX(PL_formtarget); + lines++; + gotsome = FALSE; + break; + + case FF_LITERAL: /* append <arg> literal chars */ + to_copy = *fpc++; + source = (U8 *)f; + f += to_copy; + trans = '~'; + item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv); + goto append; + + case FF_SKIP: /* skip <arg> chars in format */ + f += *fpc++; + break; + + case FF_FETCH: /* get next item and set field size to <arg> */ + arg = *fpc++; + f += arg; + fieldsize = arg; + + if (MARK < SP) + sv = *++MARK; + else { + sv = &PL_sv_no; + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); + } + if (SvTAINTED(sv)) + SvTAINTED_on(PL_formtarget); + break; + + case FF_CHECKNL: /* find max len of item (up to \n) that fits field */ + { + const char *s = item = SvPV_const(sv, len); + const char *send = s + len; itemsize = 0; - item_is_utf8 = DO_UTF8(sv); + item_is_utf8 = DO_UTF8(sv); while (s < send) { if (!isCNTRL(*s)) gotsome = TRUE; @@ -619,17 +619,17 @@ PP(pp_formline) } itembytes = s - item; chophere = s; - break; - } + break; + } - case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */ - { - const char *s = item = SvPV_const(sv, len); - const char *send = s + len; + case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */ + { + const char *s = item = SvPV_const(sv, len); + const char *send = s + len; I32 size = 0; chophere = NULL; - item_is_utf8 = DO_UTF8(sv); + item_is_utf8 = DO_UTF8(sv); while (s < send) { /* look for a legal split position */ if (isSPACE(*s)) { @@ -678,37 +678,37 @@ PP(pp_formline) } itembytes = chophere - item; - break; - } - - case FF_SPACE: /* append padding space (diff of field, item size) */ - arg = fieldsize - itemsize; - if (arg) { - fieldsize -= arg; - while (arg-- > 0) - *t++ = ' '; - } - break; - - case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */ - arg = fieldsize - itemsize; - if (arg) { - arg /= 2; - fieldsize -= arg; - while (arg-- > 0) - *t++ = ' '; - } - break; - - case FF_ITEM: /* append a text item, while blanking ctrl chars */ - to_copy = itembytes; - source = (U8 *)item; - trans = 1; - goto append; - - case FF_CHOP: /* (for ^*) chop the current item */ - if (sv != &PL_sv_no) { - const char *s = chophere; + break; + } + + case FF_SPACE: /* append padding space (diff of field, item size) */ + arg = fieldsize - itemsize; + if (arg) { + fieldsize -= arg; + while (arg-- > 0) + *t++ = ' '; + } + break; + + case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */ + arg = fieldsize - itemsize; + if (arg) { + arg /= 2; + fieldsize -= arg; + while (arg-- > 0) + *t++ = ' '; + } + break; + + case FF_ITEM: /* append a text item, while blanking ctrl chars */ + to_copy = itembytes; + source = (U8 *)item; + trans = 1; + goto append; + + case FF_CHOP: /* (for ^*) chop the current item */ + if (sv != &PL_sv_no) { + const char *s = chophere; if (!copied_form && ((sv == tmpForm || SvSMAGICAL(sv)) || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) { @@ -726,154 +726,154 @@ PP(pp_formline) copied_form = TRUE; } - if (chopspace) { - while (isSPACE(*s)) - s++; - } + if (chopspace) { + while (isSPACE(*s)) + s++; + } if (SvPOKp(sv)) sv_chop(sv,s); else /* tied, overloaded or similar strangeness. * Do it the hard way */ sv_setpvn(sv, s, len - (s-item)); - SvSETMAGIC(sv); - break; - } + SvSETMAGIC(sv); + break; + } /* FALLTHROUGH */ - case FF_LINESNGL: /* process ^* */ - chopspace = 0; + case FF_LINESNGL: /* process ^* */ + chopspace = 0; /* FALLTHROUGH */ - case FF_LINEGLOB: /* process @* */ - { - const bool oneline = fpc[-1] == FF_LINESNGL; - const char *s = item = SvPV_const(sv, len); - const char *const send = s + len; - - item_is_utf8 = DO_UTF8(sv); - chophere = s + len; - if (!len) - break; - trans = 0; - gotsome = TRUE; - source = (U8 *) s; - to_copy = len; - while (s < send) { - if (*s++ == '\n') { - if (oneline) { - to_copy = s - item - 1; - chophere = s; - break; - } else { - if (s == send) { - to_copy--; - } else - lines++; - } - } - } - } - - append: - /* append to_copy bytes from source to PL_formstring. - * item_is_utf8 implies source is utf8. - * if trans, translate certain characters during the copy */ - { - U8 *tmp = NULL; - STRLEN grow = 0; - - SvCUR_set(PL_formtarget, - t - SvPVX_const(PL_formtarget)); - - if (targ_is_utf8 && !item_is_utf8) { - source = tmp = bytes_to_utf8(source, &to_copy); + case FF_LINEGLOB: /* process @* */ + { + const bool oneline = fpc[-1] == FF_LINESNGL; + const char *s = item = SvPV_const(sv, len); + const char *const send = s + len; + + item_is_utf8 = DO_UTF8(sv); + chophere = s + len; + if (!len) + break; + trans = 0; + gotsome = TRUE; + source = (U8 *) s; + to_copy = len; + while (s < send) { + if (*s++ == '\n') { + if (oneline) { + to_copy = s - item - 1; + chophere = s; + break; + } else { + if (s == send) { + to_copy--; + } else + lines++; + } + } + } + } + + append: + /* append to_copy bytes from source to PL_formstring. + * item_is_utf8 implies source is utf8. + * if trans, translate certain characters during the copy */ + { + U8 *tmp = NULL; + STRLEN grow = 0; + + SvCUR_set(PL_formtarget, + t - SvPVX_const(PL_formtarget)); + + if (targ_is_utf8 && !item_is_utf8) { + source = tmp = bytes_to_utf8(source, &to_copy); grow = to_copy; - } else { - if (item_is_utf8 && !targ_is_utf8) { - U8 *s; - /* Upgrade targ to UTF8, and then we reduce it to - a problem we have a simple solution for. - Don't need get magic. */ - sv_utf8_upgrade_nomg(PL_formtarget); - targ_is_utf8 = TRUE; - /* re-calculate linemark */ - s = (U8*)SvPVX(PL_formtarget); - /* the bytes we initially allocated to append the - * whole line may have been gobbled up during the - * upgrade, so allocate a whole new line's worth - * for safety */ - grow = linemax; - while (linemark--) - s += UTF8_SAFE_SKIP(s, + } else { + if (item_is_utf8 && !targ_is_utf8) { + U8 *s; + /* Upgrade targ to UTF8, and then we reduce it to + a problem we have a simple solution for. + Don't need get magic. */ + sv_utf8_upgrade_nomg(PL_formtarget); + targ_is_utf8 = TRUE; + /* re-calculate linemark */ + s = (U8*)SvPVX(PL_formtarget); + /* the bytes we initially allocated to append the + * whole line may have been gobbled up during the + * upgrade, so allocate a whole new line's worth + * for safety */ + grow = linemax; + while (linemark--) + s += UTF8_SAFE_SKIP(s, (U8 *) SvEND(PL_formtarget)); - linemark = s - (U8*)SvPVX(PL_formtarget); - } - /* Easy. They agree. */ - assert (item_is_utf8 == targ_is_utf8); - } - if (!trans) - /* @* and ^* are the only things that can exceed - * the linemax, so grow by the output size, plus - * a whole new form's worth in case of any further - * output */ - grow = linemax + to_copy; - if (grow) - SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1); - t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); - - Copy(source, t, to_copy, char); - if (trans) { - /* blank out ~ or control chars, depending on trans. - * works on bytes not chars, so relies on not - * matching utf8 continuation bytes */ - U8 *s = (U8*)t; - U8 *send = s + to_copy; - while (s < send) { - const int ch = *s; - if (trans == '~' ? (ch == '~') : isCNTRL(ch)) - *s = ' '; - s++; - } - } - - t += to_copy; - SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy); - if (tmp) - Safefree(tmp); - break; - } - - case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */ - arg = *fpc++; - fmt = (const char *) - ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff); - goto ff_dec; - - case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */ - arg = *fpc++; - fmt = (const char *) - ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff); - ff_dec: - /* If the field is marked with ^ and the value is undefined, - blank it out. */ - if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) { - arg = fieldsize; - while (arg--) - *t++ = ' '; - break; - } - gotsome = TRUE; - value = SvNV(sv); - /* overflow evidence */ - if (num_overflow(value, fieldsize, arg)) { - arg = fieldsize; - while (arg--) - *t++ = '#'; - break; - } - /* Formats aren't yet marked for locales, so assume "yes". */ - { + linemark = s - (U8*)SvPVX(PL_formtarget); + } + /* Easy. They agree. */ + assert (item_is_utf8 == targ_is_utf8); + } + if (!trans) + /* @* and ^* are the only things that can exceed + * the linemax, so grow by the output size, plus + * a whole new form's worth in case of any further + * output */ + grow = linemax + to_copy; + if (grow) + SvGROW(PL_formtarget, SvCUR(PL_formtarget) + grow + 1); + t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); + + Copy(source, t, to_copy, char); + if (trans) { + /* blank out ~ or control chars, depending on trans. + * works on bytes not chars, so relies on not + * matching utf8 continuation bytes */ + U8 *s = (U8*)t; + U8 *send = s + to_copy; + while (s < send) { + const int ch = *s; + if (trans == '~' ? (ch == '~') : isCNTRL(ch)) + *s = ' '; + s++; + } + } + + t += to_copy; + SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy); + if (tmp) + Safefree(tmp); + break; + } + + case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */ + arg = *fpc++; + fmt = (const char *) + ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff); + goto ff_dec; + + case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */ + arg = *fpc++; + fmt = (const char *) + ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff); + ff_dec: + /* If the field is marked with ^ and the value is undefined, + blank it out. */ + if ((arg & FORM_NUM_BLANK) && !SvOK(sv)) { + arg = fieldsize; + while (arg--) + *t++ = ' '; + break; + } + gotsome = TRUE; + value = SvNV(sv); + /* overflow evidence */ + if (num_overflow(value, fieldsize, arg)) { + arg = fieldsize; + while (arg--) + *t++ = '#'; + break; + } + /* Formats aren't yet marked for locales, so assume "yes". */ + { Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)); int len; DECLARATION_FOR_LC_NUMERIC_MANIPULATION; @@ -896,73 +896,73 @@ PP(pp_formline) #endif PERL_MY_SNPRINTF_POST_GUARD(len, max); RESTORE_LC_NUMERIC(); - } - t += fieldsize; - break; - - case FF_NEWLINE: /* delete trailing spaces, then append \n */ - f++; - while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ; - t++; - *t++ = '\n'; - break; - - case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */ - arg = *fpc++; - if (gotsome) { - if (arg) { /* repeat until fields exhausted? */ - fpc--; - goto end; - } - } - else { - t = SvPVX(PL_formtarget) + linemark; - lines--; - } - break; - - case FF_MORE: /* replace long end of string with '...' */ - { - const char *s = chophere; - const char *send = item + len; - if (chopspace) { - while (isSPACE(*s) && (s < send)) - s++; - } - if (s < send) { - char *s1; - arg = fieldsize - itemsize; - if (arg) { - fieldsize -= arg; - while (arg-- > 0) - *t++ = ' '; - } - s1 = t - 3; - if (strBEGINs(s1," ")) { - while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1])) - s1--; - } - *s1++ = '.'; - *s1++ = '.'; - *s1++ = '.'; - } - break; - } - - case FF_END: /* tidy up, then return */ - end: - assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget)); - *t = '\0'; - SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); - if (targ_is_utf8) - SvUTF8_on(PL_formtarget); - FmLINES(PL_formtarget) += lines; - SP = ORIGMARK; - if (fpc[-1] == FF_BLANK) - RETURNOP(cLISTOP->op_first); - else - RETPUSHYES; - } + } + t += fieldsize; + break; + + case FF_NEWLINE: /* delete trailing spaces, then append \n */ + f++; + while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ; + t++; + *t++ = '\n'; + break; + + case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */ + arg = *fpc++; + if (gotsome) { + if (arg) { /* repeat until fields exhausted? */ + fpc--; + goto end; + } + } + else { + t = SvPVX(PL_formtarget) + linemark; + lines--; + } + break; + + case FF_MORE: /* replace long end of string with '...' */ + { + const char *s = chophere; + const char *send = item + len; + if (chopspace) { + while (isSPACE(*s) && (s < send)) + s++; + } + if (s < send) { + char *s1; + arg = fieldsize - itemsize; + if (arg) { + fieldsize -= arg; + while (arg-- > 0) + *t++ = ' '; + } + s1 = t - 3; + if (strBEGINs(s1," ")) { + while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1])) + s1--; + } + *s1++ = '.'; + *s1++ = '.'; + *s1++ = '.'; + } + break; + } + + case FF_END: /* tidy up, then return */ + end: + assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget)); + *t = '\0'; + SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); + if (targ_is_utf8) + SvUTF8_on(PL_formtarget); + FmLINES(PL_formtarget) += lines; + SP = ORIGMARK; + if (fpc[-1] == FF_BLANK) + RETURNOP(cLISTOP->op_first); + else + RETPUSHYES; + } } } @@ -973,10 +973,10 @@ PP(pp_grepstart) SV *src; if (PL_stack_base + TOPMARK == SP) { - (void)POPMARK; - if (GIMME_V == G_SCALAR) - XPUSHs(&PL_sv_zero); - RETURNOP(PL_op->op_next->op_next); + (void)POPMARK; + if (GIMME_V == G_SCALAR) + XPUSHs(&PL_sv_zero); + RETURNOP(PL_op->op_next->op_next); } PL_stack_sp = PL_stack_base + TOPMARK + 1; Perl_pp_pushmark(aTHX); /* push dst */ @@ -990,15 +990,15 @@ PP(pp_grepstart) src = PL_stack_base[TOPMARK]; if (SvPADTMP(src)) { - src = PL_stack_base[TOPMARK] = sv_mortalcopy(src); - PL_tmps_floor++; + src = PL_stack_base[TOPMARK] = sv_mortalcopy(src); + PL_tmps_floor++; } SvTEMP_off(src); DEFSV_set(src); PUTBACK; if (PL_op->op_type == OP_MAPSTART) - Perl_pp_pushmark(aTHX); /* push top */ + Perl_pp_pushmark(aTHX); /* push top */ return ((LOGOP*)PL_op->op_next)->op_other; } @@ -1017,127 +1017,127 @@ PP(pp_mapwhile) /* if there are new items, push them into the destination list */ if (items && gimme != G_VOID) { - /* might need to make room back there first */ - if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { - /* XXX this implementation is very pessimal because the stack - * is repeatedly extended for every set of items. Is possible - * to do this without any stack extension or copying at all - * by maintaining a separate list over which the map iterates - * (like foreach does). --gsar */ - - /* everything in the stack after the destination list moves - * towards the end the stack by the amount of room needed */ - shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); - - /* items to shift up (accounting for the moved source pointer) */ - count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); - - /* This optimization is by Ben Tilly and it does - * things differently from what Sarathy (gsar) - * is describing. The downside of this optimization is - * that leaves "holes" (uninitialized and hopefully unused areas) - * to the Perl stack, but on the other hand this - * shouldn't be a problem. If Sarathy's idea gets - * implemented, this optimization should become - * irrelevant. --jhi */ + /* might need to make room back there first */ + if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) { + /* XXX this implementation is very pessimal because the stack + * is repeatedly extended for every set of items. Is possible + * to do this without any stack extension or copying at all + * by maintaining a separate list over which the map iterates + * (like foreach does). --gsar */ + + /* everything in the stack after the destination list moves + * towards the end the stack by the amount of room needed */ + shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]); + + /* items to shift up (accounting for the moved source pointer) */ + count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1); + + /* This optimization is by Ben Tilly and it does + * things differently from what Sarathy (gsar) + * is describing. The downside of this optimization is + * that leaves "holes" (uninitialized and hopefully unused areas) + * to the Perl stack, but on the other hand this + * shouldn't be a problem. If Sarathy's idea gets + * implemented, this optimization should become + * irrelevant. --jhi */ if (shift < count) shift = count; /* Avoid shifting too often --Ben Tilly */ - EXTEND(SP,shift); - src = SP; - dst = (SP += shift); - PL_markstack_ptr[-1] += shift; - *PL_markstack_ptr += shift; - while (count--) - *dst-- = *src--; - } - /* copy the new items down to the destination list */ - dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; - if (gimme == G_ARRAY) { - /* add returned items to the collection (making mortal copies - * if necessary), then clear the current temps stack frame - * *except* for those items. We do this splicing the items - * into the start of the tmps frame (so some items may be on - * the tmps stack twice), then moving PL_tmps_floor above - * them, then freeing the frame. That way, the only tmps that - * accumulate over iterations are the return values for map. - * We have to do to this way so that everything gets correctly - * freed if we die during the map. - */ - I32 tmpsbase; - I32 i = items; - /* make space for the slice */ - EXTEND_MORTAL(items); - tmpsbase = PL_tmps_floor + 1; - Move(PL_tmps_stack + tmpsbase, - PL_tmps_stack + tmpsbase + items, - PL_tmps_ix - PL_tmps_floor, - SV*); - PL_tmps_ix += items; - - while (i-- > 0) { - SV *sv = POPs; - if (!SvTEMP(sv)) - sv = sv_mortalcopy(sv); - *dst-- = sv; - PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv); - } - /* clear the stack frame except for the items */ - PL_tmps_floor += items; - FREETMPS; - /* FREETMPS may have cleared the TEMP flag on some of the items */ - i = items; - while (i-- > 0) - SvTEMP_on(PL_tmps_stack[--tmpsbase]); - } - else { - /* scalar context: we don't care about which values map returns - * (we use undef here). And so we certainly don't want to do mortal - * copies of meaningless values. */ - while (items-- > 0) { - (void)POPs; - *dst-- = &PL_sv_undef; - } - FREETMPS; - } + EXTEND(SP,shift); + src = SP; + dst = (SP += shift); + PL_markstack_ptr[-1] += shift; + *PL_markstack_ptr += shift; + while (count--) + *dst-- = *src--; + } + /* copy the new items down to the destination list */ + dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1; + if (gimme == G_ARRAY) { + /* add returned items to the collection (making mortal copies + * if necessary), then clear the current temps stack frame + * *except* for those items. We do this splicing the items + * into the start of the tmps frame (so some items may be on + * the tmps stack twice), then moving PL_tmps_floor above + * them, then freeing the frame. That way, the only tmps that + * accumulate over iterations are the return values for map. + * We have to do to this way so that everything gets correctly + * freed if we die during the map. + */ + I32 tmpsbase; + I32 i = items; + /* make space for the slice */ + EXTEND_MORTAL(items); + tmpsbase = PL_tmps_floor + 1; + Move(PL_tmps_stack + tmpsbase, + PL_tmps_stack + tmpsbase + items, + PL_tmps_ix - PL_tmps_floor, + SV*); + PL_tmps_ix += items; + + while (i-- > 0) { + SV *sv = POPs; + if (!SvTEMP(sv)) + sv = sv_mortalcopy(sv); + *dst-- = sv; + PL_tmps_stack[tmpsbase++] = SvREFCNT_inc_simple(sv); + } + /* clear the stack frame except for the items */ + PL_tmps_floor += items; + FREETMPS; + /* FREETMPS may have cleared the TEMP flag on some of the items */ + i = items; + while (i-- > 0) + SvTEMP_on(PL_tmps_stack[--tmpsbase]); + } + else { + /* scalar context: we don't care about which values map returns + * (we use undef here). And so we certainly don't want to do mortal + * copies of meaningless values. */ + while (items-- > 0) { + (void)POPs; + *dst-- = &PL_sv_undef; + } + FREETMPS; + } } else { - FREETMPS; + FREETMPS; } LEAVE_with_name("grep_item"); /* exit inner scope */ /* All done yet? */ if (PL_markstack_ptr[-1] > TOPMARK) { - (void)POPMARK; /* pop top */ - LEAVE_with_name("grep"); /* exit outer scope */ - (void)POPMARK; /* pop src */ - items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; - (void)POPMARK; /* pop dst */ - SP = PL_stack_base + POPMARK; /* pop original mark */ - if (gimme == G_SCALAR) { - dTARGET; - XPUSHi(items); - } - else if (gimme == G_ARRAY) - SP += items; - RETURN; + (void)POPMARK; /* pop top */ + LEAVE_with_name("grep"); /* exit outer scope */ + (void)POPMARK; /* pop src */ + items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; + (void)POPMARK; /* pop dst */ + SP = PL_stack_base + POPMARK; /* pop original mark */ + if (gimme == G_SCALAR) { + dTARGET; + XPUSHi(items); + } + else if (gimme == G_ARRAY) + SP += items; + RETURN; } else { - SV *src; + SV *src; - ENTER_with_name("grep_item"); /* enter inner scope */ - SAVEVPTR(PL_curpm); + ENTER_with_name("grep_item"); /* enter inner scope */ + SAVEVPTR(PL_curpm); - /* set $_ to the new source item */ - src = PL_stack_base[PL_markstack_ptr[-1]]; - if (SvPADTMP(src)) { + /* set $_ to the new source item */ + src = PL_stack_base[PL_markstack_ptr[-1]]; + if (SvPADTMP(src)) { src = sv_mortalcopy(src); } - SvTEMP_off(src); - DEFSV_set(src); + SvTEMP_off(src); + DEFSV_set(src); - RETURNOP(cLOGOP->op_other); + RETURNOP(cLOGOP->op_other); } } @@ -1147,12 +1147,12 @@ PP(pp_range) { dTARG; if (GIMME_V == G_ARRAY) - return NORMAL; + return NORMAL; GETTARGET; if (SvTRUE_NN(targ)) - return cLOGOP->op_other; + return cLOGOP->op_other; else - return NORMAL; + return NORMAL; } PP(pp_flip) @@ -1160,41 +1160,41 @@ PP(pp_flip) dSP; if (GIMME_V == G_ARRAY) { - RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); + RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } else { - dTOPss; - SV * const targ = PAD_SV(PL_op->op_targ); - int flip = 0; - - if (PL_op->op_private & OPpFLIP_LINENUM) { - if (GvIO(PL_last_in_gv)) { - flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); - } - else { - GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); - if (gv && GvSV(gv)) - flip = SvIV(sv) == SvIV(GvSV(gv)); - } - } else { - flip = SvTRUE_NN(sv); - } - if (flip) { - sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); - if (PL_op->op_flags & OPf_SPECIAL) { - sv_setiv(targ, 1); - SETs(targ); - RETURN; - } - else { - sv_setiv(targ, 0); - SP--; - RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); - } - } + dTOPss; + SV * const targ = PAD_SV(PL_op->op_targ); + int flip = 0; + + if (PL_op->op_private & OPpFLIP_LINENUM) { + if (GvIO(PL_last_in_gv)) { + flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); + } + else { + GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); + if (gv && GvSV(gv)) + flip = SvIV(sv) == SvIV(GvSV(gv)); + } + } else { + flip = SvTRUE_NN(sv); + } + if (flip) { + sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1); + if (PL_op->op_flags & OPf_SPECIAL) { + sv_setiv(targ, 1); + SETs(targ); + RETURN; + } + else { + sv_setiv(targ, 0); + SP--; + RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); + } + } SvPVCLEAR(TARG); - SETs(targ); - RETURN; + SETs(targ); + RETURN; } } @@ -1206,9 +1206,9 @@ PP(pp_flip) perlop [#133695] */ #define RANGE_IS_NUMERIC(left,right) ( \ - SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ - SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ - (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ + SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \ + SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \ + (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \ looks_like_number(left)) && SvPOKp(left) \ && !(*SvPVX_const(left) == '0' && SvCUR(left)>1 ) )) \ && (!SvOK(right) || looks_like_number(right)))) @@ -1218,21 +1218,21 @@ PP(pp_flop) dSP; if (GIMME_V == G_ARRAY) { - dPOPPOPssrl; - - SvGETMAGIC(left); - SvGETMAGIC(right); - - if (RANGE_IS_NUMERIC(left,right)) { - IV i, j, n; - if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) || - (SvOK(right) && (SvIOK(right) - ? SvIsUV(right) && SvUV(right) > IV_MAX - : SvNV_nomg(right) > (NV) IV_MAX))) - DIE(aTHX_ "Range iterator outside integer range"); - i = SvIV_nomg(left); - j = SvIV_nomg(right); - if (j >= i) { + dPOPPOPssrl; + + SvGETMAGIC(left); + SvGETMAGIC(right); + + if (RANGE_IS_NUMERIC(left,right)) { + IV i, j, n; + if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) || + (SvOK(right) && (SvIOK(right) + ? SvIsUV(right) && SvUV(right) > IV_MAX + : SvNV_nomg(right) > (NV) IV_MAX))) + DIE(aTHX_ "Range iterator outside integer range"); + i = SvIV_nomg(left); + j = SvIV_nomg(right); + if (j >= i) { /* Dance carefully around signed max. */ bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1); if (!overflow) { @@ -1249,59 +1249,59 @@ PP(pp_flop) } if (overflow) Perl_croak(aTHX_ "Out of memory during list extend"); - EXTEND_MORTAL(n); - EXTEND(SP, n); - } - else - n = 0; - while (n--) { - SV * const sv = sv_2mortal(newSViv(i)); - PUSHs(sv); + EXTEND_MORTAL(n); + EXTEND(SP, n); + } + else + n = 0; + while (n--) { + SV * const sv = sv_2mortal(newSViv(i)); + PUSHs(sv); if (n) /* avoid incrementing above IV_MAX */ i++; - } - } - else { - STRLEN len, llen; - const char * const lpv = SvPV_nomg_const(left, llen); - const char * const tmps = SvPV_nomg_const(right, len); - - SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP); + } + } + else { + STRLEN len, llen; + const char * const lpv = SvPV_nomg_const(left, llen); + const char * const tmps = SvPV_nomg_const(right, len); + + SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP); if (DO_UTF8(right) && IN_UNI_8_BIT) len = sv_len_utf8_nomg(right); - while (!SvNIOKp(sv) && SvCUR(sv) <= len) { - XPUSHs(sv); - if (strEQ(SvPVX_const(sv),tmps)) - break; - sv = sv_2mortal(newSVsv(sv)); - sv_inc(sv); - } - } + while (!SvNIOKp(sv) && SvCUR(sv) <= len) { + XPUSHs(sv); + if (strEQ(SvPVX_const(sv),tmps)) + break; + sv = sv_2mortal(newSVsv(sv)); + sv_inc(sv); + } + } } else { - dTOPss; - SV * const targ = PAD_SV(cUNOP->op_first->op_targ); - int flop = 0; - sv_inc(targ); - - if (PL_op->op_private & OPpFLIP_LINENUM) { - if (GvIO(PL_last_in_gv)) { - flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); - } - else { - GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); - if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv)); - } - } - else { - flop = SvTRUE_NN(sv); - } - - if (flop) { - sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); - sv_catpvs(targ, "E0"); - } - SETs(targ); + dTOPss; + SV * const targ = PAD_SV(cUNOP->op_first->op_targ); + int flop = 0; + sv_inc(targ); + + if (PL_op->op_private & OPpFLIP_LINENUM) { + if (GvIO(PL_last_in_gv)) { + flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); + } + else { + GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); + if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv)); + } + } + else { + flop = SvTRUE_NN(sv); + } + + if (flop) { + sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); + sv_catpvs(targ, "E0"); + } + SETs(targ); } RETURN; @@ -1333,29 +1333,29 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) PERL_ARGS_ASSERT_DOPOPTOLABEL; for (i = cxstack_ix; i >= 0; i--) { - const PERL_CONTEXT * const cx = &cxstack[i]; - switch (CxTYPE(cx)) { - case CXt_SUBST: - case CXt_SUB: - case CXt_FORMAT: - case CXt_EVAL: - case CXt_NULL: - /* diag_listed_as: Exiting subroutine via %s */ - Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", - context_name[CxTYPE(cx)], OP_NAME(PL_op)); - if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */ - return -1; - break; - case CXt_LOOP_PLAIN: - case CXt_LOOP_LAZYIV: - case CXt_LOOP_LAZYSV: - case CXt_LOOP_LIST: - case CXt_LOOP_ARY: - { + const PERL_CONTEXT * const cx = &cxstack[i]; + switch (CxTYPE(cx)) { + case CXt_SUBST: + case CXt_SUB: + case CXt_FORMAT: + case CXt_EVAL: + case CXt_NULL: + /* diag_listed_as: Exiting subroutine via %s */ + Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); + if (CxTYPE(cx) == CXt_NULL) /* sort BLOCK */ + return -1; + break; + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: + { STRLEN cx_label_len = 0; U32 cx_label_flags = 0; - const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags); - if (!cx_label || !( + const char *cx_label = CxLABEL_len_flags(cx, &cx_label_len, &cx_label_flags); + if (!cx_label || !( ( (cx_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ? (flags & SVf_UTF8) ? (bytes_cmp_utf8( @@ -1366,14 +1366,14 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags) (const U8*)cx_label, cx_label_len) == 0) : (len == cx_label_len && ((cx_label == label) || memEQ(cx_label, label, len))) )) { - DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n", - (long)i, cx_label)); - continue; - } - DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label)); - return i; - } - } + DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n", + (long)i, cx_label)); + continue; + } + DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label)); + return i; + } + } } return i; } @@ -1395,11 +1395,11 @@ Perl_block_gimme(pTHX) const I32 cxix = dopopto_cursub(); U8 gimme; if (cxix < 0) - return G_VOID; + return G_VOID; gimme = (cxstack[cxix].blk_gimme & G_WANT); if (!gimme) - Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme); + Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme); return gimme; } @@ -1411,9 +1411,9 @@ Perl_is_lvalue_sub(pTHX) assert(cxix >= 0); /* We should only be called from inside subs */ if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv)) - return CxLVAL(cxstack + cxix); + return CxLVAL(cxstack + cxix); else - return 0; + return 0; } /* only used by cx_pushsub() */ @@ -1424,9 +1424,9 @@ Perl_was_lvalue_sub(pTHX) assert(cxix >= 0); /* We should only be called from inside subs */ if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv)) - return CxLVAL(cxstack + cxix); + return CxLVAL(cxstack + cxix); else - return 0; + return 0; } STATIC I32 @@ -1440,11 +1440,11 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) #endif for (i = startingblock; i >= 0; i--) { - const PERL_CONTEXT * const cx = &cxstk[i]; - switch (CxTYPE(cx)) { - default: - continue; - case CXt_SUB: + const PERL_CONTEXT * const cx = &cxstk[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_SUB: /* in sub foo { /(?{...})/ }, foo ends up on the CX stack * twice; the first for the normal foo() call, and the second * for a faked up re-entry into the sub to execute the @@ -1452,11 +1452,11 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) if (cx->cx_type & CXp_SUB_RE_FAKE) continue; /* FALLTHROUGH */ - case CXt_EVAL: - case CXt_FORMAT: - DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i)); - return i; - } + case CXt_EVAL: + case CXt_FORMAT: + DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i)); + return i; + } } return i; } @@ -1466,14 +1466,14 @@ S_dopoptoeval(pTHX_ I32 startingblock) { I32 i; for (i = startingblock; i >= 0; i--) { - const PERL_CONTEXT *cx = &cxstack[i]; - switch (CxTYPE(cx)) { - default: - continue; - case CXt_EVAL: - DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i)); - return i; - } + const PERL_CONTEXT *cx = &cxstack[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_EVAL: + DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i)); + return i; + } } return i; } @@ -1483,27 +1483,27 @@ S_dopoptoloop(pTHX_ I32 startingblock) { I32 i; for (i = startingblock; i >= 0; i--) { - const PERL_CONTEXT * const cx = &cxstack[i]; - switch (CxTYPE(cx)) { - case CXt_SUBST: - case CXt_SUB: - case CXt_FORMAT: - case CXt_EVAL: - case CXt_NULL: - /* diag_listed_as: Exiting subroutine via %s */ - Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", - context_name[CxTYPE(cx)], OP_NAME(PL_op)); - if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */ - return -1; - break; - case CXt_LOOP_PLAIN: - case CXt_LOOP_LAZYIV: - case CXt_LOOP_LAZYSV: - case CXt_LOOP_LIST: - case CXt_LOOP_ARY: - DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i)); - return i; - } + const PERL_CONTEXT * const cx = &cxstack[i]; + switch (CxTYPE(cx)) { + case CXt_SUBST: + case CXt_SUB: + case CXt_FORMAT: + case CXt_EVAL: + case CXt_NULL: + /* diag_listed_as: Exiting subroutine via %s */ + Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); + if ((CxTYPE(cx)) == CXt_NULL) /* sort BLOCK */ + return -1; + break; + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: + DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i)); + return i; + } } return i; } @@ -1515,25 +1515,25 @@ S_dopoptogivenfor(pTHX_ I32 startingblock) { I32 i; for (i = startingblock; i >= 0; i--) { - const PERL_CONTEXT *cx = &cxstack[i]; - switch (CxTYPE(cx)) { - default: - continue; - case CXt_GIVEN: - DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i)); - return i; - case CXt_LOOP_PLAIN: + const PERL_CONTEXT *cx = &cxstack[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_GIVEN: + DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i)); + return i; + case CXt_LOOP_PLAIN: assert(!(cx->cx_type & CXp_FOR_DEF)); - break; - case CXt_LOOP_LAZYIV: - case CXt_LOOP_LAZYSV: - case CXt_LOOP_LIST: - case CXt_LOOP_ARY: + break; + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: if (cx->cx_type & CXp_FOR_DEF) { - DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i)); - return i; - } - } + DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i)); + return i; + } + } } return i; } @@ -1543,14 +1543,14 @@ S_dopoptowhen(pTHX_ I32 startingblock) { I32 i; for (i = startingblock; i >= 0; i--) { - const PERL_CONTEXT *cx = &cxstack[i]; - switch (CxTYPE(cx)) { - default: - continue; - case CXt_WHEN: - DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i)); - return i; - } + const PERL_CONTEXT *cx = &cxstack[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_WHEN: + DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i)); + return i; + } } return i; } @@ -1566,57 +1566,57 @@ void Perl_dounwind(pTHX_ I32 cxix) { if (!PL_curstackinfo) /* can happen if die during thread cloning */ - return; + return; while (cxstack_ix > cxix) { PERL_CONTEXT *cx = CX_CUR(); - CX_DEBUG(cx, "UNWIND"); - /* Note: we don't need to restore the base context info till the end. */ + CX_DEBUG(cx, "UNWIND"); + /* Note: we don't need to restore the base context info till the end. */ CX_LEAVE_SCOPE(cx); - switch (CxTYPE(cx)) { - case CXt_SUBST: - CX_POPSUBST(cx); + switch (CxTYPE(cx)) { + case CXt_SUBST: + CX_POPSUBST(cx); /* CXt_SUBST is not a block context type, so skip the * cx_popblock(cx) below */ if (cxstack_ix == cxix + 1) { cxstack_ix--; return; } - break; - case CXt_SUB: - cx_popsub(cx); - break; - case CXt_EVAL: - cx_popeval(cx); - break; - case CXt_LOOP_PLAIN: - case CXt_LOOP_LAZYIV: - case CXt_LOOP_LAZYSV: - case CXt_LOOP_LIST: - case CXt_LOOP_ARY: - cx_poploop(cx); - break; - case CXt_WHEN: - cx_popwhen(cx); - break; - case CXt_GIVEN: - cx_popgiven(cx); - break; - case CXt_BLOCK: - case CXt_NULL: + break; + case CXt_SUB: + cx_popsub(cx); + break; + case CXt_EVAL: + cx_popeval(cx); + break; + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_LIST: + case CXt_LOOP_ARY: + cx_poploop(cx); + break; + case CXt_WHEN: + cx_popwhen(cx); + break; + case CXt_GIVEN: + cx_popgiven(cx); + break; + case CXt_BLOCK: + case CXt_NULL: /* these two don't have a POPFOO() */ - break; - case CXt_FORMAT: - cx_popformat(cx); - break; - } + break; + case CXt_FORMAT: + cx_popformat(cx); + break; + } if (cxstack_ix == cxix + 1) { cx_popblock(cx); } - cxstack_ix--; + cxstack_ix--; } } @@ -1627,19 +1627,19 @@ Perl_qerror(pTHX_ SV *err) PERL_ARGS_ASSERT_QERROR; if (PL_in_eval) { - if (PL_in_eval & EVAL_KEEPERR) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, + if (PL_in_eval & EVAL_KEEPERR) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, SVfARG(err)); - } - else - sv_catsv(ERRSV, err); + } + else + sv_catsv(ERRSV, err); } else if (PL_errors) - sv_catsv(PL_errors, err); + sv_catsv(PL_errors, err); else - Perl_warn(aTHX_ "%" SVf, SVfARG(err)); + Perl_warn(aTHX_ "%" SVf, SVfARG(err)); if (PL_parser) - ++PL_parser->error_count; + ++PL_parser->error_count; } @@ -1708,7 +1708,7 @@ Perl_die_unwind(pTHX_ SV *msv) PERL_ARGS_ASSERT_DIE_UNWIND; if (in_eval) { - I32 cxix; + I32 cxix; /* We need to keep this SV alive through all the stack unwinding * and FREETMPSing below, while ensuing that it doesn't leak @@ -1722,64 +1722,64 @@ Perl_die_unwind(pTHX_ SV *msv) exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); } - /* - * Historically, perl used to set ERRSV ($@) early in the die - * process and rely on it not getting clobbered during unwinding. - * That sucked, because it was liable to get clobbered, so the - * setting of ERRSV used to emit the exception from eval{} has - * been moved to much later, after unwinding (see just before - * JMPENV_JUMP below). However, some modules were relying on the - * early setting, by examining $@ during unwinding to use it as - * a flag indicating whether the current unwinding was caused by - * an exception. It was never a reliable flag for that purpose, - * being totally open to false positives even without actual - * clobberage, but was useful enough for production code to - * semantically rely on it. - * - * We'd like to have a proper introspective interface that - * explicitly describes the reason for whatever unwinding - * operations are currently in progress, so that those modules - * work reliably and $@ isn't further overloaded. But we don't - * have one yet. In its absence, as a stopgap measure, ERRSV is - * now *additionally* set here, before unwinding, to serve as the - * (unreliable) flag that it used to. - * - * This behaviour is temporary, and should be removed when a - * proper way to detect exceptional unwinding has been developed. - * As of 2010-12, the authors of modules relying on the hack - * are aware of the issue, because the modules failed on - * perls 5.13.{1..7} which had late setting of $@ without this - * early-setting hack. - */ - if (!(in_eval & EVAL_KEEPERR)) { + /* + * Historically, perl used to set ERRSV ($@) early in the die + * process and rely on it not getting clobbered during unwinding. + * That sucked, because it was liable to get clobbered, so the + * setting of ERRSV used to emit the exception from eval{} has + * been moved to much later, after unwinding (see just before + * JMPENV_JUMP below). However, some modules were relying on the + * early setting, by examining $@ during unwinding to use it as + * a flag indicating whether the current unwinding was caused by + * an exception. It was never a reliable flag for that purpose, + * being totally open to false positives even without actual + * clobberage, but was useful enough for production code to + * semantically rely on it. + * + * We'd like to have a proper introspective interface that + * explicitly describes the reason for whatever unwinding + * operations are currently in progress, so that those modules + * work reliably and $@ isn't further overloaded. But we don't + * have one yet. In its absence, as a stopgap measure, ERRSV is + * now *additionally* set here, before unwinding, to serve as the + * (unreliable) flag that it used to. + * + * This behaviour is temporary, and should be removed when a + * proper way to detect exceptional unwinding has been developed. + * As of 2010-12, the authors of modules relying on the hack + * are aware of the issue, because the modules failed on + * perls 5.13.{1..7} which had late setting of $@ without this + * early-setting hack. + */ + if (!(in_eval & EVAL_KEEPERR)) { /* remove any read-only/magic from the SV, so we don't get infinite recursion when setting ERRSV */ SANE_ERRSV(); - sv_setsv_flags(ERRSV, exceptsv, + sv_setsv_flags(ERRSV, exceptsv, (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL)); } - if (in_eval & EVAL_KEEPERR) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, - SVfARG(exceptsv)); - } - - while ((cxix = dopoptoeval(cxstack_ix)) < 0 - && PL_curstackinfo->si_prev) - { - dounwind(-1); - POPSTACK; - } - - if (cxix >= 0) { - PERL_CONTEXT *cx; - SV **oldsp; + if (in_eval & EVAL_KEEPERR) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, + SVfARG(exceptsv)); + } + + while ((cxix = dopoptoeval(cxstack_ix)) < 0 + && PL_curstackinfo->si_prev) + { + dounwind(-1); + POPSTACK; + } + + if (cxix >= 0) { + PERL_CONTEXT *cx; + SV **oldsp; U8 gimme; - JMPENV *restartjmpenv; - OP *restartop; + JMPENV *restartjmpenv; + OP *restartop; - if (cxix < cxstack_ix) - dounwind(cxix); + if (cxix < cxstack_ix) + dounwind(cxix); cx = CX_CUR(); assert(CxTYPE(cx) == CXt_EVAL); @@ -1787,12 +1787,12 @@ Perl_die_unwind(pTHX_ SV *msv) /* return false to the caller of eval */ oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; - if (gimme == G_SCALAR) - *++oldsp = &PL_sv_undef; - PL_stack_sp = oldsp; + if (gimme == G_SCALAR) + *++oldsp = &PL_sv_undef; + PL_stack_sp = oldsp; - restartjmpenv = cx->blk_eval.cur_top_env; - restartop = cx->blk_eval.retop; + restartjmpenv = cx->blk_eval.cur_top_env; + restartop = cx->blk_eval.retop; /* We need a FREETMPS here to avoid late-called destructors * clobbering $@ *after* we set it below, e.g. @@ -1819,15 +1819,15 @@ Perl_die_unwind(pTHX_ SV *msv) */ S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2); - if (!(in_eval & EVAL_KEEPERR)) { + if (!(in_eval & EVAL_KEEPERR)) { SANE_ERRSV(); - sv_setsv(ERRSV, exceptsv); + sv_setsv(ERRSV, exceptsv); } - PL_restartjmpenv = restartjmpenv; - PL_restartop = restartop; - JMPENV_JUMP(3); - NOT_REACHED; /* NOTREACHED */ - } + PL_restartjmpenv = restartjmpenv; + PL_restartop = restartop; + JMPENV_JUMP(3); + NOT_REACHED; /* NOTREACHED */ + } } write_to_stderr(exceptsv); @@ -1839,9 +1839,9 @@ PP(pp_xor) { dSP; dPOPTOPssrl; if (SvTRUE_NN(left) != SvTRUE_NN(right)) - RETSETYES; + RETSETYES; else - RETSETNO; + RETSETNO; } /* @@ -1875,21 +1875,21 @@ Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) const PERL_SI *top_si = PL_curstackinfo; for (;;) { - /* we may be in a higher stacklevel, so dig down deeper */ - while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { - top_si = top_si->si_prev; - ccstack = top_si->si_cxstack; - cxix = dopoptosub_at(ccstack, top_si->si_cxix); - } - if (cxix < 0) - return NULL; - /* caller() should not report the automatic calls to &DB::sub */ - if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && - ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) - count++; - if (!count--) - break; - cxix = dopoptosub_at(ccstack, cxix - 1); + /* we may be in a higher stacklevel, so dig down deeper */ + while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { + top_si = top_si->si_prev; + ccstack = top_si->si_cxstack; + cxix = dopoptosub_at(ccstack, top_si->si_cxix); + } + if (cxix < 0) + return NULL; + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && + ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) + count++; + if (!count--) + break; + cxix = dopoptosub_at(ccstack, cxix - 1); } cx = &ccstack[cxix]; @@ -1897,11 +1897,11 @@ Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1); - /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the - field below is defined for any cx. */ - /* caller() should not report the automatic calls to &DB::sub */ - if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) - cx = &ccstack[dbcxix]; + /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the + field below is defined for any cx. */ + /* caller() should not report the automatic calls to &DB::sub */ + if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) + cx = &ccstack[dbcxix]; } return cx; @@ -1920,17 +1920,17 @@ PP(pp_caller) if (MAXARG) { if (has_arg) - count = POPi; + count = POPi; else (void)POPs; } cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx); if (!cx) { - if (gimme != G_ARRAY) { - EXTEND(SP, 1); - RETPUSHUNDEF; - } - RETURN; + if (gimme != G_ARRAY) { + EXTEND(SP, 1); + RETPUSHUNDEF; + } + RETURN; } CX_DEBUG(cx, "CALLER"); @@ -1940,56 +1940,56 @@ PP(pp_caller) : NULL; if (gimme != G_ARRAY) { EXTEND(SP, 1); - if (!stash_hek) - PUSHs(&PL_sv_undef); - else { - dTARGET; - sv_sethek(TARG, stash_hek); - PUSHs(TARG); - } - RETURN; + if (!stash_hek) + PUSHs(&PL_sv_undef); + else { + dTARGET; + sv_sethek(TARG, stash_hek); + PUSHs(TARG); + } + RETURN; } EXTEND(SP, 11); if (!stash_hek) - PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); else { - dTARGET; - sv_sethek(TARG, stash_hek); - PUSHTARG; + dTARGET; + sv_sethek(TARG, stash_hek); + PUSHTARG; } mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop), - cx->blk_sub.retop, TRUE); + cx->blk_sub.retop, TRUE); if (!lcop) - lcop = cx->blk_oldcop; + lcop = cx->blk_oldcop; mPUSHu(CopLINE(lcop)); if (!has_arg) - RETURN; + RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - /* So is ccstack[dbcxix]. */ - if (CvHASGV(dbcx->blk_sub.cv)) { - PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0)); - PUSHs(boolSV(CxHASARGS(cx))); - } - else { - PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); - PUSHs(boolSV(CxHASARGS(cx))); - } + /* So is ccstack[dbcxix]. */ + if (CvHASGV(dbcx->blk_sub.cv)) { + PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0)); + PUSHs(boolSV(CxHASARGS(cx))); + } + else { + PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); + PUSHs(boolSV(CxHASARGS(cx))); + } } else { - PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); - PUSHs(&PL_sv_zero); + PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); + PUSHs(&PL_sv_zero); } gimme = cx->blk_gimme; if (gimme == G_VOID) - PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); else - PUSHs(boolSV((gimme & G_WANT) == G_ARRAY)); + PUSHs(boolSV((gimme & G_WANT) == G_ARRAY)); if (CxTYPE(cx) == CXt_EVAL) { - /* eval STRING */ - if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { + /* eval STRING */ + if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { SV *cur_text = cx->blk_eval.cur_text; if (SvCUR(cur_text) >= 2) { PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2, @@ -2000,61 +2000,61 @@ PP(pp_caller) PUSHs(sv_2mortal(newSVsv(cur_text))); } - PUSHs(&PL_sv_no); - } - /* require */ - else if (cx->blk_eval.old_namesv) { - mPUSHs(newSVsv(cx->blk_eval.old_namesv)); - PUSHs(&PL_sv_yes); - } - /* eval BLOCK (try blocks have old_namesv == 0) */ - else { - PUSHs(&PL_sv_undef); - PUSHs(&PL_sv_undef); - } + PUSHs(&PL_sv_no); + } + /* require */ + else if (cx->blk_eval.old_namesv) { + mPUSHs(newSVsv(cx->blk_eval.old_namesv)); + PUSHs(&PL_sv_yes); + } + /* eval BLOCK (try blocks have old_namesv == 0) */ + else { + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + } } else { - PUSHs(&PL_sv_undef); - PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); } if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx) - && CopSTASH_eq(PL_curcop, PL_debstash)) + && CopSTASH_eq(PL_curcop, PL_debstash)) { /* slot 0 of the pad contains the original @_ */ - AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV( + AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV( PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ cx->blk_sub.olddepth+1]))[0]); - const SSize_t off = AvARRAY(ary) - AvALLOC(ary); + const SSize_t off = AvARRAY(ary) - AvALLOC(ary); - Perl_init_dbargs(aTHX); + Perl_init_dbargs(aTHX); - if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) - av_extend(PL_dbargs, AvFILLp(ary) + off); + if (AvMAX(PL_dbargs) < AvFILLp(ary) + off) + av_extend(PL_dbargs, AvFILLp(ary) + off); if (AvFILLp(ary) + 1 + off) Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); - AvFILLp(PL_dbargs) = AvFILLp(ary) + off; + AvFILLp(PL_dbargs) = AvFILLp(ary) + off; } mPUSHi(CopHINTS_get(cx->blk_oldcop)); { - SV * mask ; - STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ; + SV * mask ; + STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ; - if (old_warnings == pWARN_NONE) + if (old_warnings == pWARN_NONE) mask = newSVpvn(WARN_NONEstring, WARNsize) ; - else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0) + else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0) mask = &PL_sv_undef ; else if (old_warnings == pWARN_ALL || - (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { - mask = newSVpvn(WARN_ALLstring, WARNsize) ; - } + (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { + mask = newSVpvn(WARN_ALLstring, WARNsize) ; + } else mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); mPUSHs(mask); } PUSHs(cx->blk_oldcop->cop_hints_hash ? - sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0)))) - : &PL_sv_undef); + sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0)))) + : &PL_sv_undef); RETURN; } @@ -2065,10 +2065,10 @@ PP(pp_reset) STRLEN len = 0; if (MAXARG < 1 || (!TOPs && !POPs)) { EXTEND(SP, 1); - tmps = NULL, len = 0; + tmps = NULL, len = 0; } else - tmps = SvPVx_const(POPs, len); + tmps = SvPVx_const(POPs, len); sv_resetpvn(tmps, len, CopSTASH(PL_curcop)); PUSHs(&PL_sv_yes); RETURN; @@ -2086,39 +2086,39 @@ PP(pp_dbstate) PERL_ASYNC_CHECK(); if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ - || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv) + || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv) { - dSP; - PERL_CONTEXT *cx; - const U8 gimme = G_ARRAY; - GV * const gv = PL_DBgv; - CV * cv = NULL; + dSP; + PERL_CONTEXT *cx; + const U8 gimme = G_ARRAY; + GV * const gv = PL_DBgv; + CV * cv = NULL; if (gv && isGV_with_GP(gv)) cv = GvCV(gv); - if (!cv || (!CvROOT(cv) && !CvXSUB(cv))) - DIE(aTHX_ "No DB::DB routine defined"); + if (!cv || (!CvROOT(cv) && !CvXSUB(cv))) + DIE(aTHX_ "No DB::DB routine defined"); - if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) - /* don't do recursive DB::DB call */ - return NORMAL; + if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG)) + /* don't do recursive DB::DB call */ + return NORMAL; - if (CvISXSUB(cv)) { + if (CvISXSUB(cv)) { ENTER; SAVEI32(PL_debug); PL_debug = 0; SAVESTACK_POS(); SAVETMPS; - PUSHMARK(SP); - (void)(*CvXSUB(cv))(aTHX_ cv); - FREETMPS; - LEAVE; - return NORMAL; - } - else { - cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix); - cx_pushsub(cx, cv, PL_op->op_next, 0); + PUSHMARK(SP); + (void)(*CvXSUB(cv))(aTHX_ cv); + FREETMPS; + LEAVE; + return NORMAL; + } + else { + cx = cx_pushblock(CXt_SUB, gimme, SP, PL_savestack_ix); + cx_pushsub(cx, cv, PL_op->op_next, 0); /* OP_DBSTATE's op_private holds hint bits rather than * the lvalue-ish flags seen in OP_ENTERSUB. So cancel * any CxLVAL() flags that have now been mis-calculated */ @@ -2127,15 +2127,15 @@ PP(pp_dbstate) SAVEI32(PL_debug); PL_debug = 0; SAVESTACK_POS(); - CvDEPTH(cv)++; - if (CvDEPTH(cv) >= 2) - pad_push(CvPADLIST(cv), CvDEPTH(cv)); - PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); - RETURNOP(CvSTART(cv)); - } + CvDEPTH(cv)++; + if (CvDEPTH(cv) >= 2) + pad_push(CvPADLIST(cv), CvDEPTH(cv)); + PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); + RETURNOP(CvSTART(cv)); + } } else - return NORMAL; + return NORMAL; } @@ -2159,7 +2159,7 @@ PP(pp_leave) if (PL_op->op_flags & OPf_SPECIAL) /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */ - cx->blk_oldpm = PL_curpm; + cx->blk_oldpm = PL_curpm; oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; @@ -2209,21 +2209,21 @@ PP(pp_enteriter) U8 cxflags = 0; if (PL_op->op_targ) { /* "my" variable */ - itervarp = &PAD_SVl(PL_op->op_targ); + itervarp = &PAD_SVl(PL_op->op_targ); itersave = *(SV**)itervarp; assert(itersave); - if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */ + if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */ /* the SV currently in the pad slot is never live during * iteration (the slot is always aliased to one of the items) * so it's always stale */ - SvPADSTALE_on(itersave); - } + SvPADSTALE_on(itersave); + } SvREFCNT_inc_simple_void_NN(itersave); - cxflags = CXp_FOR_PAD; + cxflags = CXp_FOR_PAD; } else { - SV * const sv = POPs; - itervarp = (void *)sv; + SV * const sv = POPs; + itervarp = (void *)sv; if (LIKELY(isGV(sv))) { /* symbol table variable */ itersave = GvSV(sv); SvREFCNT_inc_simple_void(itersave); @@ -2254,56 +2254,56 @@ PP(pp_enteriter) /* OPf_STACKED implies either a single array: for(@), with a * single AV on the stack, or a range: for (1..5), with 1 and 5 on * the stack */ - SV *maybe_ary = POPs; - if (SvTYPE(maybe_ary) != SVt_PVAV) { + SV *maybe_ary = POPs; + if (SvTYPE(maybe_ary) != SVt_PVAV) { /* range */ - dPOPss; - SV * const right = maybe_ary; - if (UNLIKELY(cxflags & CXp_FOR_LVREF)) - DIE(aTHX_ "Assigned value is not a reference"); - SvGETMAGIC(sv); - SvGETMAGIC(right); - if (RANGE_IS_NUMERIC(sv,right)) { - cx->cx_type |= CXt_LOOP_LAZYIV; - if (S_outside_integer(aTHX_ sv) || + dPOPss; + SV * const right = maybe_ary; + if (UNLIKELY(cxflags & CXp_FOR_LVREF)) + DIE(aTHX_ "Assigned value is not a reference"); + SvGETMAGIC(sv); + SvGETMAGIC(right); + if (RANGE_IS_NUMERIC(sv,right)) { + cx->cx_type |= CXt_LOOP_LAZYIV; + if (S_outside_integer(aTHX_ sv) || S_outside_integer(aTHX_ right)) - DIE(aTHX_ "Range iterator outside integer range"); - cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv); - cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right); - } - else { - cx->cx_type |= CXt_LOOP_LAZYSV; - cx->blk_loop.state_u.lazysv.cur = newSVsv(sv); - cx->blk_loop.state_u.lazysv.end = right; - SvREFCNT_inc_simple_void_NN(right); - (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur); - /* This will do the upgrade to SVt_PV, and warn if the value - is uninitialised. */ - (void) SvPV_nolen_const(right); - /* Doing this avoids a check every time in pp_iter in pp_hot.c - to replace !SvOK() with a pointer to "". */ - if (!SvOK(right)) { - SvREFCNT_dec(right); - cx->blk_loop.state_u.lazysv.end = &PL_sv_no; - } - } - } - else /* SvTYPE(maybe_ary) == SVt_PVAV */ { + DIE(aTHX_ "Range iterator outside integer range"); + cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv); + cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right); + } + else { + cx->cx_type |= CXt_LOOP_LAZYSV; + cx->blk_loop.state_u.lazysv.cur = newSVsv(sv); + cx->blk_loop.state_u.lazysv.end = right; + SvREFCNT_inc_simple_void_NN(right); + (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur); + /* This will do the upgrade to SVt_PV, and warn if the value + is uninitialised. */ + (void) SvPV_nolen_const(right); + /* Doing this avoids a check every time in pp_iter in pp_hot.c + to replace !SvOK() with a pointer to "". */ + if (!SvOK(right)) { + SvREFCNT_dec(right); + cx->blk_loop.state_u.lazysv.end = &PL_sv_no; + } + } + } + else /* SvTYPE(maybe_ary) == SVt_PVAV */ { /* for (@array) {} */ cx->cx_type |= CXt_LOOP_ARY; - cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); - SvREFCNT_inc_simple_void_NN(maybe_ary); - cx->blk_loop.state_u.ary.ix = - (PL_op->op_private & OPpITER_REVERSED) ? - AvFILL(cx->blk_loop.state_u.ary.ary) + 1 : - -1; - } + cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); + SvREFCNT_inc_simple_void_NN(maybe_ary); + cx->blk_loop.state_u.ary.ix = + (PL_op->op_private & OPpITER_REVERSED) ? + AvFILL(cx->blk_loop.state_u.ary.ary) + 1 : + -1; + } /* EXTEND(SP, 1) not needed in this branch because we just did POPs */ } else { /* iterating over items on the stack */ cx->cx_type |= CXt_LOOP_LIST; cx->blk_oldsp = SP - PL_stack_base; - cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base; + cx->blk_loop.state_u.stack.basesp = MARK - PL_stack_base; cx->blk_loop.state_u.stack.ix = (PL_op->op_private & OPpITER_REVERSED) ? cx->blk_oldsp + 1 @@ -2381,7 +2381,7 @@ PP(pp_leavesublv) /* entry zero of a stack is always PL_sv_undef, which * simplifies converting a '()' return into undef in scalar context */ assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef); - return 0; + return 0; } gimme = cx->blk_gimme; @@ -2527,7 +2527,7 @@ PP(pp_return) CxTYPE(cx) == CXt_SUB && CvLVALUE(cx->blk_sub.cv) ? 3 : 0); SPAGAIN; - dounwind(cxix); + dounwind(cxix); cx = &cxstack[cxix]; /* CX stack may have been realloced */ } else { @@ -2573,7 +2573,7 @@ PP(pp_return) case CXt_FORMAT: return Perl_pp_leavewrite(aTHX); default: - DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx)); + DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx)); } } @@ -2584,29 +2584,29 @@ S_unwind_loop(pTHX) { I32 cxix; if (PL_op->op_flags & OPf_SPECIAL) { - cxix = dopoptoloop(cxstack_ix); - if (cxix < 0) - /* diag_listed_as: Can't "last" outside a loop block */ - Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", + cxix = dopoptoloop(cxstack_ix); + if (cxix < 0) + /* diag_listed_as: Can't "last" outside a loop block */ + Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", OP_NAME(PL_op)); } else { - dSP; - STRLEN label_len; - const char * const label = - PL_op->op_flags & OPf_STACKED - ? SvPV(TOPs,label_len) - : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv); - const U32 label_flags = - PL_op->op_flags & OPf_STACKED - ? SvUTF8(POPs) - : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; - PUTBACK; + dSP; + STRLEN label_len; + const char * const label = + PL_op->op_flags & OPf_STACKED + ? SvPV(TOPs,label_len) + : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv); + const U32 label_flags = + PL_op->op_flags & OPf_STACKED + ? SvUTF8(POPs) + : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; + PUTBACK; cxix = dopoptolabel(label, label_len, label_flags); - if (cxix < 0) - /* diag_listed_as: Label not found for "last %s" */ - Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"", - OP_NAME(PL_op), + if (cxix < 0) + /* diag_listed_as: Label not found for "last %s" */ + Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"", + OP_NAME(PL_op), SVfARG(PL_op->op_flags & OPf_STACKED && !SvGMAGICAL(TOPp1s) ? TOPp1s @@ -2615,7 +2615,7 @@ S_unwind_loop(pTHX) label_flags | SVs_TEMP))); } if (cxix < cxstack_ix) - dounwind(cxix); + dounwind(cxix); return &cxstack[cxix]; } @@ -2667,11 +2667,11 @@ PP(pp_redo) OP* redo_op = cx->blk_loop.my_op->op_redoop; if (redo_op->op_type == OP_ENTER) { - /* pop one less context to avoid $x being freed in while (my $x..) */ - cxstack_ix++; + /* pop one less context to avoid $x being freed in while (my $x..) */ + cxstack_ix++; cx = CX_CUR(); - assert(CxTYPE(cx) == CXt_BLOCK); - redo_op = redo_op->op_next; + assert(CxTYPE(cx) == CXt_BLOCK); + redo_op = redo_op->op_next; } FREETMPS; @@ -2694,47 +2694,47 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac PERL_ARGS_ASSERT_DOFINDLABEL; if (ops >= oplimit) - Perl_croak(aTHX_ "%s", too_deep); + Perl_croak(aTHX_ "%s", too_deep); if (o->op_type == OP_LEAVE || - o->op_type == OP_SCOPE || - o->op_type == OP_LEAVELOOP || - o->op_type == OP_LEAVESUB || - o->op_type == OP_LEAVETRY || - o->op_type == OP_LEAVEGIVEN) + o->op_type == OP_SCOPE || + o->op_type == OP_LEAVELOOP || + o->op_type == OP_LEAVESUB || + o->op_type == OP_LEAVETRY || + o->op_type == OP_LEAVEGIVEN) { - *ops++ = cUNOPo->op_first; + *ops++ = cUNOPo->op_first; } else if (oplimit - opstack < GOTO_DEPTH) { if (o->op_flags & OPf_KIDS - && cUNOPo->op_first->op_type == OP_PUSHMARK) { - *ops++ = UNENTERABLE; + && cUNOPo->op_first->op_type == OP_PUSHMARK) { + *ops++ = UNENTERABLE; } else if (o->op_flags & OPf_KIDS && PL_opargs[o->op_type] - && OP_CLASS(o) != OA_LOGOP - && o->op_type != OP_LINESEQ - && o->op_type != OP_SREFGEN - && o->op_type != OP_ENTEREVAL - && o->op_type != OP_GLOB - && o->op_type != OP_RV2CV) { - OP * const kid = cUNOPo->op_first; - if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid)) - *ops++ = UNENTERABLE; + && OP_CLASS(o) != OA_LOGOP + && o->op_type != OP_LINESEQ + && o->op_type != OP_SREFGEN + && o->op_type != OP_ENTEREVAL + && o->op_type != OP_GLOB + && o->op_type != OP_RV2CV) { + OP * const kid = cUNOPo->op_first; + if (OP_GIMME(kid, 0) != G_SCALAR || OpHAS_SIBLING(kid)) + *ops++ = UNENTERABLE; } } if (ops >= oplimit) - Perl_croak(aTHX_ "%s", too_deep); + Perl_croak(aTHX_ "%s", too_deep); *ops = 0; if (o->op_flags & OPf_KIDS) { - OP *kid; - OP * const kid1 = cUNOPo->op_first; - /* First try all the kids at this level, since that's likeliest. */ - for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { - if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + OP *kid; + OP * const kid1 = cUNOPo->op_first; + /* First try all the kids at this level, since that's likeliest. */ + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { STRLEN kid_label_len; U32 kid_label_flags; - const char *kid_label = CopLABEL_len_flags(kCOP, + const char *kid_label = CopLABEL_len_flags(kCOP, &kid_label_len, &kid_label_flags); - if (kid_label && ( + if (kid_label && ( ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ? (flags & SVf_UTF8) ? (bytes_cmp_utf8( @@ -2745,32 +2745,32 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac (const U8*)kid_label, kid_label_len) == 0) : ( len == kid_label_len && ((kid_label == label) || memEQ(kid_label, label, len))))) - return kid; - } - } - for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { - bool first_kid_of_binary = FALSE; - if (kid == PL_lastgotoprobe) - continue; - if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { - if (ops == opstack) - *ops++ = kid; - else if (ops[-1] != UNENTERABLE - && (ops[-1]->op_type == OP_NEXTSTATE || - ops[-1]->op_type == OP_DBSTATE)) - ops[-1] = kid; - else - *ops++ = kid; - } - if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) { - first_kid_of_binary = TRUE; - ops--; - } - if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) - return o; - if (first_kid_of_binary) - *ops++ = UNENTERABLE; - } + return kid; + } + } + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { + bool first_kid_of_binary = FALSE; + if (kid == PL_lastgotoprobe) + continue; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + if (ops == opstack) + *ops++ = kid; + else if (ops[-1] != UNENTERABLE + && (ops[-1]->op_type == OP_NEXTSTATE || + ops[-1]->op_type == OP_DBSTATE)) + ops[-1] = kid; + else + *ops++ = kid; + } + if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) { + first_kid_of_binary = TRUE; + ops--; + } + if ((o = dofindlabel(kid, label, len, flags, ops, oplimit))) + return o; + if (first_kid_of_binary) + *ops++ = UNENTERABLE; + } } *ops = 0; return 0; @@ -2784,7 +2784,7 @@ S_check_op_type(pTHX_ OP * const o) * for each op. For now, we punt on the hard ones. */ /* XXX This comment seems to me like wishful thinking. --sprout */ if (o == UNENTERABLE) - Perl_croak(aTHX_ + Perl_croak(aTHX_ "Can't \"goto\" into a binary or list expression"); if (o->op_type == OP_ENTERITER) Perl_croak(aTHX_ @@ -2812,74 +2812,74 @@ PP(pp_goto) if (PL_op->op_flags & OPf_STACKED) { /* goto EXPR or goto &foo */ - SV * const sv = POPs; - SvGETMAGIC(sv); + SV * const sv = POPs; + SvGETMAGIC(sv); - if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { + if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { /* This egregious kludge implements goto &subroutine */ - I32 cxix; - PERL_CONTEXT *cx; - CV *cv = MUTABLE_CV(SvRV(sv)); - AV *arg = GvAV(PL_defgv); - - while (!CvROOT(cv) && !CvXSUB(cv)) { - const GV * const gv = CvGV(cv); - if (gv) { - GV *autogv; - SV *tmpstr; - /* autoloaded stub? */ - if (cv != GvCV(gv) && (cv = GvCV(gv))) - continue; - autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), - GvNAMELEN(gv), + I32 cxix; + PERL_CONTEXT *cx; + CV *cv = MUTABLE_CV(SvRV(sv)); + AV *arg = GvAV(PL_defgv); + + while (!CvROOT(cv) && !CvXSUB(cv)) { + const GV * const gv = CvGV(cv); + if (gv) { + GV *autogv; + SV *tmpstr; + /* autoloaded stub? */ + if (cv != GvCV(gv) && (cv = GvCV(gv))) + continue; + autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), + GvNAMELEN(gv), GvNAMEUTF8(gv) ? SVf_UTF8 : 0); - if (autogv && (cv = GvCV(autogv))) - continue; - tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, gv, NULL); - DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr)); - } - DIE(aTHX_ "Goto undefined subroutine"); - } - - cxix = dopopto_cursub(); + if (autogv && (cv = GvCV(autogv))) + continue; + tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, gv, NULL); + DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr)); + } + DIE(aTHX_ "Goto undefined subroutine"); + } + + cxix = dopopto_cursub(); if (cxix < 0) { DIE(aTHX_ "Can't goto subroutine outside a subroutine"); } cx = &cxstack[cxix]; - /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */ - if (CxTYPE(cx) == CXt_EVAL) { - if (CxREALEVAL(cx)) - /* diag_listed_as: Can't goto subroutine from an eval-%s */ - DIE(aTHX_ "Can't goto subroutine from an eval-string"); - else - /* diag_listed_as: Can't goto subroutine from an eval-%s */ - DIE(aTHX_ "Can't goto subroutine from an eval-block"); - } - else if (CxMULTICALL(cx)) - DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)"); - - /* First do some returnish stuff. */ - - SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */ - FREETMPS; - if (cxix < cxstack_ix) { - dounwind(cxix); + /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */ + if (CxTYPE(cx) == CXt_EVAL) { + if (CxREALEVAL(cx)) + /* diag_listed_as: Can't goto subroutine from an eval-%s */ + DIE(aTHX_ "Can't goto subroutine from an eval-string"); + else + /* diag_listed_as: Can't goto subroutine from an eval-%s */ + DIE(aTHX_ "Can't goto subroutine from an eval-block"); + } + else if (CxMULTICALL(cx)) + DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)"); + + /* First do some returnish stuff. */ + + SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */ + FREETMPS; + if (cxix < cxstack_ix) { + dounwind(cxix); } cx = CX_CUR(); - cx_topblock(cx); - SPAGAIN; + cx_topblock(cx); + SPAGAIN; /* protect @_ during save stack unwind. */ if (arg) SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg))); - assert(PL_scopestack_ix == cx->blk_oldscopesp); + assert(PL_scopestack_ix == cx->blk_oldscopesp); CX_LEAVE_SCOPE(cx); - if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { + if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { /* this is part of cx_popsub_args() */ - AV* av = MUTABLE_AV(PAD_SVl(0)); + AV* av = MUTABLE_AV(PAD_SVl(0)); assert(AvARRAY(MUTABLE_AV( PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[ CvDEPTH(cx->blk_sub.cv)])) == PL_curpad); @@ -2890,10 +2890,10 @@ PP(pp_goto) * unless pad[0] and @_ differ (e.g. if the old sub did * local *_ = []); in which case clear the old pad[0] * array in the usual way */ - if (av == arg || AvREAL(av)) + if (av == arg || AvREAL(av)) clear_defarray(av, av == arg); - else CLEAR_ARGARRAY(av); - } + else CLEAR_ARGARRAY(av); + } /* don't restore PL_comppad here. It won't be needed if the * sub we're going to is non-XS, but restoring it early then @@ -2901,66 +2901,66 @@ PP(pp_goto) * means the CX block gets processed again in dounwind, * but this time with the wrong PL_comppad */ - /* A destructor called during LEAVE_SCOPE could have undefined - * our precious cv. See bug #99850. */ - if (!CvROOT(cv) && !CvXSUB(cv)) { - const GV * const gv = CvGV(cv); - if (gv) { - SV * const tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, gv, NULL); - DIE(aTHX_ "Goto undefined subroutine &%" SVf, - SVfARG(tmpstr)); - } - DIE(aTHX_ "Goto undefined subroutine"); - } - - if (CxTYPE(cx) == CXt_SUB) { - CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth; + /* A destructor called during LEAVE_SCOPE could have undefined + * our precious cv. See bug #99850. */ + if (!CvROOT(cv) && !CvXSUB(cv)) { + const GV * const gv = CvGV(cv); + if (gv) { + SV * const tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, gv, NULL); + DIE(aTHX_ "Goto undefined subroutine &%" SVf, + SVfARG(tmpstr)); + } + DIE(aTHX_ "Goto undefined subroutine"); + } + + if (CxTYPE(cx) == CXt_SUB) { + CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth; SvREFCNT_dec_NN(cx->blk_sub.cv); } - /* Now do some callish stuff. */ - if (CvISXSUB(cv)) { - const SSize_t items = arg ? AvFILL(arg) + 1 : 0; - const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0; - SV** mark; + /* Now do some callish stuff. */ + if (CvISXSUB(cv)) { + const SSize_t items = arg ? AvFILL(arg) + 1 : 0; + const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0; + SV** mark; ENTER; SAVETMPS; SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ - /* put GvAV(defgv) back onto stack */ - if (items) { - EXTEND(SP, items+1); /* @_ could have been extended. */ - } - mark = SP; - if (items) { - SSize_t index; - bool r = cBOOL(AvREAL(arg)); - for (index=0; index<items; index++) - { - SV *sv; - if (m) { - SV ** const svp = av_fetch(arg, index, 0); - sv = svp ? *svp : NULL; - } - else sv = AvARRAY(arg)[index]; - SP[index+1] = sv - ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv - : sv_2mortal(newSVavdefelem(arg, index, 1)); - } - } - SP += items; - if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { - /* Restore old @_ */ + /* put GvAV(defgv) back onto stack */ + if (items) { + EXTEND(SP, items+1); /* @_ could have been extended. */ + } + mark = SP; + if (items) { + SSize_t index; + bool r = cBOOL(AvREAL(arg)); + for (index=0; index<items; index++) + { + SV *sv; + if (m) { + SV ** const svp = av_fetch(arg, index, 0); + sv = svp ? *svp : NULL; + } + else sv = AvARRAY(arg)[index]; + SP[index+1] = sv + ? r ? SvREFCNT_inc_NN(sv_2mortal(sv)) : sv + : sv_2mortal(newSVavdefelem(arg, index, 1)); + } + } + SP += items; + if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { + /* Restore old @_ */ CX_POP_SAVEARRAY(cx); - } + } - retop = cx->blk_sub.retop; + retop = cx->blk_sub.retop; PL_comppad = cx->blk_sub.prevcomppad; PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL; - /* XS subs don't have a CXt_SUB, so pop it; + /* XS subs don't have a CXt_SUB, so pop it; * this is a cx_popblock(), less all the stuff we already did * for cx_topblock() earlier */ PL_curcop = cx->blk_oldcop; @@ -2969,78 +2969,78 @@ PP(pp_goto) CX_POP(cx); - /* Push a mark for the start of arglist */ - PUSHMARK(mark); - PUTBACK; - (void)(*CvXSUB(cv))(aTHX_ cv); - LEAVE; - goto _return; - } - else { - PADLIST * const padlist = CvPADLIST(cv); + /* Push a mark for the start of arglist */ + PUSHMARK(mark); + PUTBACK; + (void)(*CvXSUB(cv))(aTHX_ cv); + LEAVE; + goto _return; + } + else { + PADLIST * const padlist = CvPADLIST(cv); SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ /* partial unrolled cx_pushsub(): */ - cx->blk_sub.cv = cv; - cx->blk_sub.olddepth = CvDEPTH(cv); + cx->blk_sub.cv = cv; + cx->blk_sub.olddepth = CvDEPTH(cv); - CvDEPTH(cv)++; + CvDEPTH(cv)++; SvREFCNT_inc_simple_void_NN(cv); - if (CvDEPTH(cv) > 1) { - if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)) - sub_crush_depth(cv); - pad_push(padlist, CvDEPTH(cv)); - } - PL_curcop = cx->blk_oldcop; - PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); - if (CxHASARGS(cx)) - { + if (CvDEPTH(cv) > 1) { + if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)) + sub_crush_depth(cv); + pad_push(padlist, CvDEPTH(cv)); + } + PL_curcop = cx->blk_oldcop; + PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); + if (CxHASARGS(cx)) + { /* second half of donating @_ from the old sub to the * new sub: abandon the original pad[0] AV in the * new sub, and replace it with the donated @_. * pad[0] takes ownership of the extra refcount * we gave arg earlier */ - if (arg) { - SvREFCNT_dec(PAD_SVl(0)); - PAD_SVl(0) = (SV *)arg; + if (arg) { + SvREFCNT_dec(PAD_SVl(0)); + PAD_SVl(0) = (SV *)arg; SvREFCNT_inc_simple_void_NN(arg); - } - - /* GvAV(PL_defgv) might have been modified on scope - exit, so point it at arg again. */ - if (arg != GvAV(PL_defgv)) { - AV * const av = GvAV(PL_defgv); - GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg); - SvREFCNT_dec(av); - } - } - - if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ - Perl_get_db_sub(aTHX_ NULL, cv); - if (PERLDB_GOTO) { - CV * const gotocv = get_cvs("DB::goto", 0); - if (gotocv) { - PUSHMARK( PL_stack_sp ); - call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG); - PL_stack_sp--; - } - } - } - retop = CvSTART(cv); - goto putback_return; - } - } - else { + } + + /* GvAV(PL_defgv) might have been modified on scope + exit, so point it at arg again. */ + if (arg != GvAV(PL_defgv)) { + AV * const av = GvAV(PL_defgv); + GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg); + SvREFCNT_dec(av); + } + } + + if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ + Perl_get_db_sub(aTHX_ NULL, cv); + if (PERLDB_GOTO) { + CV * const gotocv = get_cvs("DB::goto", 0); + if (gotocv) { + PUSHMARK( PL_stack_sp ); + call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG); + PL_stack_sp--; + } + } + } + retop = CvSTART(cv); + goto putback_return; + } + } + else { /* goto EXPR */ - label = SvPV_nomg_const(sv, label_len); + label = SvPV_nomg_const(sv, label_len); label_flags = SvUTF8(sv); - } + } } else if (!(PL_op->op_flags & OPf_SPECIAL)) { /* goto LABEL or dump LABEL */ - label = cPVOP->op_pv; + label = cPVOP->op_pv; label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0; label_len = strlen(label); } @@ -3049,27 +3049,27 @@ PP(pp_goto) PERL_ASYNC_CHECK(); if (label_len) { - OP *gotoprobe = NULL; - bool leaving_eval = FALSE; - bool in_block = FALSE; - bool pseudo_block = FALSE; - PERL_CONTEXT *last_eval_cx = NULL; - - /* find label */ - - PL_lastgotoprobe = NULL; - *enterops = 0; - for (ix = cxstack_ix; ix >= 0; ix--) { - cx = &cxstack[ix]; - switch (CxTYPE(cx)) { - case CXt_EVAL: - leaving_eval = TRUE; + OP *gotoprobe = NULL; + bool leaving_eval = FALSE; + bool in_block = FALSE; + bool pseudo_block = FALSE; + PERL_CONTEXT *last_eval_cx = NULL; + + /* find label */ + + PL_lastgotoprobe = NULL; + *enterops = 0; + for (ix = cxstack_ix; ix >= 0; ix--) { + cx = &cxstack[ix]; + switch (CxTYPE(cx)) { + case CXt_EVAL: + leaving_eval = TRUE; if (!CxTRYBLOCK(cx)) { - gotoprobe = (last_eval_cx ? - last_eval_cx->blk_eval.old_eval_root : - PL_eval_root); - last_eval_cx = cx; - break; + gotoprobe = (last_eval_cx ? + last_eval_cx->blk_eval.old_eval_root : + PL_eval_root); + last_eval_cx = cx; + break; } /* else fall through */ case CXt_LOOP_PLAIN: @@ -3077,118 +3077,118 @@ PP(pp_goto) case CXt_LOOP_LAZYSV: case CXt_LOOP_LIST: case CXt_LOOP_ARY: - case CXt_GIVEN: - case CXt_WHEN: - gotoprobe = OpSIBLING(cx->blk_oldcop); - break; - case CXt_SUBST: - continue; - case CXt_BLOCK: - if (ix) { - gotoprobe = OpSIBLING(cx->blk_oldcop); - in_block = TRUE; - } else - gotoprobe = PL_main_root; - break; - case CXt_SUB: - gotoprobe = CvROOT(cx->blk_sub.cv); - pseudo_block = cBOOL(CxMULTICALL(cx)); - break; - case CXt_FORMAT: - case CXt_NULL: - DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); - default: - if (ix) - DIE(aTHX_ "panic: goto, type=%u, ix=%ld", - CxTYPE(cx), (long) ix); - gotoprobe = PL_main_root; - break; - } - if (gotoprobe) { + case CXt_GIVEN: + case CXt_WHEN: + gotoprobe = OpSIBLING(cx->blk_oldcop); + break; + case CXt_SUBST: + continue; + case CXt_BLOCK: + if (ix) { + gotoprobe = OpSIBLING(cx->blk_oldcop); + in_block = TRUE; + } else + gotoprobe = PL_main_root; + break; + case CXt_SUB: + gotoprobe = CvROOT(cx->blk_sub.cv); + pseudo_block = cBOOL(CxMULTICALL(cx)); + break; + case CXt_FORMAT: + case CXt_NULL: + DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); + default: + if (ix) + DIE(aTHX_ "panic: goto, type=%u, ix=%ld", + CxTYPE(cx), (long) ix); + gotoprobe = PL_main_root; + break; + } + if (gotoprobe) { OP *sibl1, *sibl2; - retop = dofindlabel(gotoprobe, label, label_len, label_flags, - enterops, enterops + GOTO_DEPTH); - if (retop) - break; - if ( (sibl1 = OpSIBLING(gotoprobe)) && - sibl1->op_type == OP_UNSTACK && - (sibl2 = OpSIBLING(sibl1))) + retop = dofindlabel(gotoprobe, label, label_len, label_flags, + enterops, enterops + GOTO_DEPTH); + if (retop) + break; + if ( (sibl1 = OpSIBLING(gotoprobe)) && + sibl1->op_type == OP_UNSTACK && + (sibl2 = OpSIBLING(sibl1))) { - retop = dofindlabel(sibl2, - label, label_len, label_flags, enterops, - enterops + GOTO_DEPTH); - if (retop) - break; - } - } - if (pseudo_block) - DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); - PL_lastgotoprobe = gotoprobe; - } - if (!retop) - DIE(aTHX_ "Can't find label %" UTF8f, - UTF8fARG(label_flags, label_len, label)); - - /* if we're leaving an eval, check before we pop any frames + retop = dofindlabel(sibl2, + label, label_len, label_flags, enterops, + enterops + GOTO_DEPTH); + if (retop) + break; + } + } + if (pseudo_block) + DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); + PL_lastgotoprobe = gotoprobe; + } + if (!retop) + DIE(aTHX_ "Can't find label %" UTF8f, + UTF8fARG(label_flags, label_len, label)); + + /* if we're leaving an eval, check before we pop any frames that we're not going to punt, otherwise the error - won't be caught */ + won't be caught */ - if (leaving_eval && *enterops && enterops[1]) { - I32 i; + if (leaving_eval && *enterops && enterops[1]) { + I32 i; for (i = 1; enterops[i]; i++) S_check_op_type(aTHX_ enterops[i]); - } - - if (*enterops && enterops[1]) { - I32 i = enterops[1] != UNENTERABLE - && enterops[1]->op_type == OP_ENTER && in_block - ? 2 - : 1; - if (enterops[i]) - deprecate("\"goto\" to jump into a construct"); - } - - /* pop unwanted frames */ - - if (ix < cxstack_ix) { - if (ix < 0) - DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix); - dounwind(ix); + } + + if (*enterops && enterops[1]) { + I32 i = enterops[1] != UNENTERABLE + && enterops[1]->op_type == OP_ENTER && in_block + ? 2 + : 1; + if (enterops[i]) + deprecate("\"goto\" to jump into a construct"); + } + + /* pop unwanted frames */ + + if (ix < cxstack_ix) { + if (ix < 0) + DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix); + dounwind(ix); cx = CX_CUR(); - cx_topblock(cx); - } - - /* push wanted frames */ - - if (*enterops && enterops[1]) { - OP * const oldop = PL_op; - ix = enterops[1] != UNENTERABLE - && enterops[1]->op_type == OP_ENTER && in_block - ? 2 - : 1; - for (; enterops[ix]; ix++) { - PL_op = enterops[ix]; - S_check_op_type(aTHX_ PL_op); - DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n", - OP_NAME(PL_op))); - PL_op->op_ppaddr(aTHX); - } - PL_op = oldop; - } + cx_topblock(cx); + } + + /* push wanted frames */ + + if (*enterops && enterops[1]) { + OP * const oldop = PL_op; + ix = enterops[1] != UNENTERABLE + && enterops[1]->op_type == OP_ENTER && in_block + ? 2 + : 1; + for (; enterops[ix]; ix++) { + PL_op = enterops[ix]; + S_check_op_type(aTHX_ PL_op); + DEBUG_l( Perl_deb(aTHX_ "pp_goto: Entering %s\n", + OP_NAME(PL_op))); + PL_op->op_ppaddr(aTHX); + } + PL_op = oldop; + } } if (do_dump) { #ifdef VMS - if (!retop) retop = PL_main_start; + if (!retop) retop = PL_main_start; #endif - PL_restartop = retop; - PL_do_undump = TRUE; + PL_restartop = retop; + PL_do_undump = TRUE; - my_unexec(); + my_unexec(); - PL_restartop = 0; /* hmm, must be GNU unexec().. */ - PL_do_undump = FALSE; + PL_restartop = 0; /* hmm, must be GNU unexec().. */ + PL_do_undump = FALSE; } putback_return: @@ -3204,16 +3204,16 @@ PP(pp_exit) I32 anum; if (MAXARG < 1) - anum = 0; + anum = 0; else if (!TOPs) { - anum = 0; (void)POPs; + anum = 0; (void)POPs; } else { - anum = SvIVx(POPs); + anum = SvIVx(POPs); #ifdef VMS - if (anum == 1 - && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0))) - anum = 0; + if (anum == 1 + && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0))) + anum = 0; VMSISH_HUSHED = VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH); #endif @@ -3236,18 +3236,18 @@ S_save_lines(pTHX_ AV *array, SV *sv) PERL_ARGS_ASSERT_SAVE_LINES; while (s && s < send) { - const char *t; - SV * const tmpstr = newSV_type(SVt_PVMG); + const char *t; + SV * const tmpstr = newSV_type(SVt_PVMG); - t = (const char *)memchr(s, '\n', send - s); - if (t) - t++; - else - t = send; + t = (const char *)memchr(s, '\n', send - s); + if (t) + t++; + else + t = send; - sv_setpvn(tmpstr, s, t - s); - av_store(array, line++, tmpstr); - s = t; + sv_setpvn(tmpstr, s, t - s); + av_store(array, line++, tmpstr); + s = t; } } @@ -3277,24 +3277,24 @@ S_docatch(pTHX_ Perl_ppaddr_t firstpp) JMPENV_PUSH(ret); switch (ret) { case 0: - PL_op = firstpp(aTHX); + PL_op = firstpp(aTHX); redo_body: - CALLRUNOPS(aTHX); - break; + CALLRUNOPS(aTHX); + break; case 3: - /* die caught by an inner eval - continue inner loop */ - if (PL_restartop && PL_restartjmpenv == PL_top_env) { - PL_restartjmpenv = NULL; - PL_op = PL_restartop; - PL_restartop = 0; - goto redo_body; - } - /* FALLTHROUGH */ + /* die caught by an inner eval - continue inner loop */ + if (PL_restartop && PL_restartjmpenv == PL_top_env) { + PL_restartjmpenv = NULL; + PL_op = PL_restartop; + PL_restartop = 0; + goto redo_body; + } + /* FALLTHROUGH */ default: - JMPENV_POP; - PL_op = oldop; - JMPENV_JUMP(ret); - NOT_REACHED; /* NOTREACHED */ + JMPENV_POP; + PL_op = oldop; + JMPENV_JUMP(ret); + NOT_REACHED; /* NOTREACHED */ } JMPENV_POP; PL_op = oldop; @@ -3328,43 +3328,43 @@ Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp) int level = 0; if (db_seqp) - *db_seqp = + *db_seqp = PL_curcop == &PL_compiling ? PL_cop_seqmax : PL_curcop->cop_seq; for (si = PL_curstackinfo; si; si = si->si_prev) { I32 ix; - for (ix = si->si_cxix; ix >= 0; ix--) { - const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); - CV *cv = NULL; - if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - cv = cx->blk_sub.cv; - /* skip DB:: code */ - if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { - *db_seqp = cx->blk_oldcop->cop_seq; - continue; - } + for (ix = si->si_cxix; ix >= 0; ix--) { + const PERL_CONTEXT *cx = &(si->si_cxstack[ix]); + CV *cv = NULL; + if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { + cv = cx->blk_sub.cv; + /* skip DB:: code */ + if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { + *db_seqp = cx->blk_oldcop->cop_seq; + continue; + } if (cx->cx_type & CXp_SUB_RE) continue; - } - else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) - cv = cx->blk_eval.cv; - if (cv) { - switch (cond) { - case FIND_RUNCV_padid_eq: - if (!CvPADLIST(cv) - || CvPADLIST(cv)->xpadl_id != (U32)arg) - continue; - return cv; - case FIND_RUNCV_level_eq: - if (level++ != arg) continue; + } + else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) + cv = cx->blk_eval.cv; + if (cv) { + switch (cond) { + case FIND_RUNCV_padid_eq: + if (!CvPADLIST(cv) + || CvPADLIST(cv)->xpadl_id != (U32)arg) + continue; + return cv; + case FIND_RUNCV_level_eq: + if (level++ != arg) continue; /* FALLTHROUGH */ - default: - return cv; - } - } - } + default: + return cv; + } + } + } } return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv; } @@ -3385,14 +3385,14 @@ S_try_yyparse(pTHX_ int gramtype) JMPENV_PUSH(ret); switch (ret) { case 0: - ret = yyparse(gramtype) ? 1 : 0; - break; + ret = yyparse(gramtype) ? 1 : 0; + break; case 3: - break; + break; default: - JMPENV_POP; - JMPENV_JUMP(ret); - NOT_REACHED; /* NOTREACHED */ + JMPENV_POP; + JMPENV_JUMP(ret); + NOT_REACHED; /* NOTREACHED */ } JMPENV_POP; return ret; @@ -3425,8 +3425,8 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) CV *evalcv; PL_in_eval = (in_require - ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) - : (EVAL_INEVAL | + ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) + : (EVAL_INEVAL | ((PL_op->op_private & OPpEVAL_RE_REPARSING) ? EVAL_RE_REPARSING : 0))); @@ -3452,14 +3452,14 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) /* make sure we compile in the right package */ if (CopSTASH_ne(PL_curcop, PL_curstash)) { - SAVEGENERICSV(PL_curstash); - PL_curstash = (HV *)CopSTASH(PL_curcop); - if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL; - else { - SvREFCNT_inc_simple_void(PL_curstash); - save_item(PL_curstname); - sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash)); - } + SAVEGENERICSV(PL_curstash); + PL_curstash = (HV *)CopSTASH(PL_curcop); + if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL; + else { + SvREFCNT_inc_simple_void(PL_curstash); + save_item(PL_curstname); + sv_sethek(PL_curstname, HvNAME_HEK(PL_curstash)); + } } /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ SAVESPTR(PL_beginav); @@ -3479,19 +3479,19 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) PL_eval_root = NULL; PL_curcop = &PL_compiling; if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) - PL_in_eval |= EVAL_KEEPERR; + PL_in_eval |= EVAL_KEEPERR; else - CLEAR_ERRSV(); + CLEAR_ERRSV(); SAVEHINTS(); if (clear_hints) { - PL_hints = HINTS_DEFAULT; - hv_clear(GvHV(PL_hintgv)); + PL_hints = HINTS_DEFAULT; + hv_clear(GvHV(PL_hintgv)); CLEARFEATUREBITS(); } else { - PL_hints = saveop->op_private & OPpEVAL_COPHH - ? oldcurcop->cop_hints : (U32)saveop->op_targ; + PL_hints = saveop->op_private & OPpEVAL_COPHH + ? oldcurcop->cop_hints : (U32)saveop->op_targ; /* making 'use re eval' not be in scope when compiling the * qr/mabye_has_runtime_code_block/ ensures that we don't get @@ -3501,37 +3501,37 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) if (PL_in_eval & EVAL_RE_REPARSING) PL_hints &= ~HINT_RE_EVAL; - if (hh) { - /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ - SvREFCNT_dec(GvHV(PL_hintgv)); - GvHV(PL_hintgv) = hh; + if (hh) { + /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ + SvREFCNT_dec(GvHV(PL_hintgv)); + GvHV(PL_hintgv) = hh; FETCHFEATUREBITSHH(hh); - } + } } SAVECOMPILEWARNINGS(); if (clear_hints) { - if (PL_dowarn & G_WARN_ALL_ON) - PL_compiling.cop_warnings = pWARN_ALL ; - else if (PL_dowarn & G_WARN_ALL_OFF) - PL_compiling.cop_warnings = pWARN_NONE ; - else - PL_compiling.cop_warnings = pWARN_STD ; + if (PL_dowarn & G_WARN_ALL_ON) + PL_compiling.cop_warnings = pWARN_ALL ; + else if (PL_dowarn & G_WARN_ALL_OFF) + PL_compiling.cop_warnings = pWARN_NONE ; + else + PL_compiling.cop_warnings = pWARN_STD ; } else { - PL_compiling.cop_warnings = - DUP_WARNINGS(oldcurcop->cop_warnings); - cophh_free(CopHINTHASH_get(&PL_compiling)); - if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) { - /* The label, if present, is the first entry on the chain. So rather - than writing a blank label in front of it (which involves an - allocation), just use the next entry in the chain. */ - PL_compiling.cop_hints_hash - = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next); - /* Check the assumption that this removed the label. */ - assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); - } - else - PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash); + PL_compiling.cop_warnings = + DUP_WARNINGS(oldcurcop->cop_warnings); + cophh_free(CopHINTHASH_get(&PL_compiling)); + if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) { + /* The label, if present, is the first entry on the chain. So rather + than writing a blank label in front of it (which involves an + allocation), just use the next entry in the chain. */ + PL_compiling.cop_hints_hash + = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next); + /* Check the assumption that this removed the label. */ + assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL); + } + else + PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash); } CALL_BLOCK_HOOKS(bhk_eval, saveop); @@ -3544,37 +3544,37 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG); if (yystatus || PL_parser->error_count || !PL_eval_root) { - PERL_CONTEXT *cx; + PERL_CONTEXT *cx; SV *errsv; - PL_op = saveop; - /* note that if yystatus == 3, then the require/eval died during + PL_op = saveop; + /* note that if yystatus == 3, then the require/eval died during * compilation, so the EVAL CX block has already been popped, and * various vars restored */ - if (yystatus != 3) { - if (PL_eval_root) { - op_free(PL_eval_root); - PL_eval_root = NULL; - } - SP = PL_stack_base + POPMARK; /* pop original mark */ + if (yystatus != 3) { + if (PL_eval_root) { + op_free(PL_eval_root); + PL_eval_root = NULL; + } + SP = PL_stack_base + POPMARK; /* pop original mark */ cx = CX_CUR(); assert(CxTYPE(cx) == CXt_EVAL); /* pop the CXt_EVAL, and if was a require, croak */ S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2); - } + } /* die_unwind() re-croaks when in require, having popped the * require EVAL context. So we should never catch a require * exception here */ - assert(!in_require); + assert(!in_require); - errsv = ERRSV; + errsv = ERRSV; if (!*(SvPV_nolen_const(errsv))) sv_setpvs(errsv, "Compilation error"); - if (gimme != G_ARRAY) PUSHs(&PL_sv_undef); - PUTBACK; - return FALSE; + if (gimme != G_ARRAY) PUSHs(&PL_sv_undef); + PUTBACK; + return FALSE; } /* Compilation successful. Now clean up */ @@ -3589,20 +3589,20 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) /* Register with debugger: */ if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { - CV * const cv = get_cvs("DB::postponed", 0); - if (cv) { - dSP; - PUSHMARK(SP); - XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); - PUTBACK; - call_sv(MUTABLE_SV(cv), G_DISCARD); - } + CV * const cv = get_cvs("DB::postponed", 0); + if (cv) { + dSP; + PUSHMARK(SP); + XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); + PUTBACK; + call_sv(MUTABLE_SV(cv), G_DISCARD); + } } if (PL_unitcheckav) { - OP *es = PL_eval_start; - call_list(PL_scopestack_ix, PL_unitcheckav); - PL_eval_start = es; + OP *es = PL_eval_start; + call_list(PL_scopestack_ix, PL_unitcheckav); + PL_eval_start = es; } CvDEPTH(evalcv) = 1; @@ -3649,19 +3649,19 @@ S_check_type_and_open(pTHX_ SV *name) st_rc = PerlLIO_stat(p, &st); if (st_rc < 0) - return NULL; + return NULL; else { - int eno; - if(S_ISBLK(st.st_mode)) { - eno = EINVAL; - goto not_file; - } - else if(S_ISDIR(st.st_mode)) { - eno = EISDIR; - not_file: - errno = eno; - return NULL; - } + int eno; + if(S_ISBLK(st.st_mode)) { + eno = EINVAL; + goto not_file; + } + else if(S_ISDIR(st.st_mode)) { + eno = EISDIR; + not_file: + errno = eno; + return NULL; + } } #endif @@ -3670,17 +3670,17 @@ S_check_type_and_open(pTHX_ SV *name) /* EACCES stops the INC search early in pp_require to implement feature RT #113422 */ if(!retio && errno == EACCES) { /* exists but probably a directory */ - int eno; - st_rc = PerlLIO_stat(p, &st); - if (st_rc >= 0) { - if(S_ISDIR(st.st_mode)) - eno = EISDIR; - else if(S_ISBLK(st.st_mode)) - eno = EINVAL; - else - eno = EACCES; - errno = eno; - } + int eno; + st_rc = PerlLIO_stat(p, &st); + if (st_rc >= 0) { + if(S_ISDIR(st.st_mode)) + eno = EISDIR; + else if(S_ISBLK(st.st_mode)) + eno = EINVAL; + else + eno = EACCES; + errno = eno; + } } #endif return retio; @@ -3708,15 +3708,15 @@ S_doopen_pm(pTHX_ SV *name) return NULL; if (memENDPs(p, namelen, ".pm")) { - SV *const pmcsv = sv_newmortal(); - PerlIO * pmcio; + SV *const pmcsv = sv_newmortal(); + PerlIO * pmcio; - SvSetSV_nosteal(pmcsv,name); - sv_catpvs(pmcsv, "c"); + SvSetSV_nosteal(pmcsv,name); + sv_catpvs(pmcsv, "c"); - pmcio = check_type_and_open(pmcsv); - if (pmcio) - return pmcio; + pmcio = check_type_and_open(pmcsv); + if (pmcio) + return pmcio; } return check_type_and_open(name); } @@ -3733,21 +3733,21 @@ S_path_is_searchable(const char *name) if (PERL_FILE_IS_ABSOLUTE(name) #ifdef WIN32 - || (*name == '.' && ((name[1] == '/' || - (name[1] == '.' && name[2] == '/')) - || (name[1] == '\\' || - ( name[1] == '.' && name[2] == '\\'))) - ) + || (*name == '.' && ((name[1] == '/' || + (name[1] == '.' && name[2] == '/')) + || (name[1] == '\\' || + ( name[1] == '.' && name[2] == '\\'))) + ) #else - || (*name == '.' && (name[1] == '/' || - (name[1] == '.' && name[2] == '/'))) + || (*name == '.' && (name[1] == '/' || + (name[1] == '.' && name[2] == '/'))) #endif - ) + ) { - return FALSE; + return FALSE; } else - return TRUE; + return TRUE; } @@ -3861,12 +3861,12 @@ S_require_file(pTHX_ SV *sv) DIE(aTHX_ "Missing or undefined argument to %s", op_name); #ifndef VMS - /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */ - if (op_is_require) { - /* can optimize to only perform one single lookup */ - svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0); - if ( svp_cached && (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)) ) RETPUSHYES; - } + /* try to return earlier (save the SAFE_PATHNAME check) if INC already got the name */ + if (op_is_require) { + /* can optimize to only perform one single lookup */ + svp_cached = hv_fetch(GvHVn(PL_incgv), (char*) name, len, 0); + if ( svp_cached && (SvGETMAGIC(*svp_cached), SvOK(*svp_cached)) ) RETPUSHYES; + } #endif if (!IS_SAFE_PATHNAME(name, len, op_name)) { @@ -3892,33 +3892,33 @@ S_require_file(pTHX_ SV *sv) */ if ((unixname = - tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))) - != NULL) { - unixlen = strlen(unixname); - vms_unixname = 1; + tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))) + != NULL) { + unixlen = strlen(unixname); + vms_unixname = 1; } else #endif { /* if not VMS or VMS name can not be translated to UNIX, pass it - * through. - */ - unixname = (char *) name; - unixlen = len; + * through. + */ + unixname = (char *) name; + unixlen = len; } if (op_is_require) { - /* reuse the previous hv_fetch result if possible */ - SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); - if ( svp ) { + /* reuse the previous hv_fetch result if possible */ + SV * const * const svp = svp_cached ? svp_cached : hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); + if ( svp ) { /* we already did a get magic if this was cached */ if (!svp_cached) SvGETMAGIC(*svp); - if (SvOK(*svp)) - RETPUSHYES; - else - DIE(aTHX_ "Attempt to reload %s aborted.\n" - "Compilation failed in require", unixname); - } + if (SvOK(*svp)) + RETPUSHYES; + else + DIE(aTHX_ "Attempt to reload %s aborted.\n" + "Compilation failed in require", unixname); + } /*XXX OPf_KIDS should always be true? -dapm 4/2017 */ if (PL_op->op_flags & OPf_KIDS) { @@ -3974,9 +3974,9 @@ S_require_file(pTHX_ SV *sv) /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load * the file directly rather than via @INC ... */ if (!path_searchable) { - /* At this point, name is SvPVX(sv) */ - tryname = name; - tryrsfp = doopen_pm(sv); + /* At this point, name is SvPVX(sv) */ + tryname = name; + tryrsfp = doopen_pm(sv); } /* ... but if we fail, still search @INC for code references; @@ -3986,207 +3986,207 @@ S_require_file(pTHX_ SV *sv) * For searchable paths, just search @INC normally */ if (!tryrsfp && !(errno == EACCES && !path_searchable)) { - AV * const ar = GvAVn(PL_incgv); - SSize_t i; + AV * const ar = GvAVn(PL_incgv); + SSize_t i; #ifdef VMS - if (vms_unixname) + if (vms_unixname) #endif - { - SV *nsv = sv; - namesv = newSV_type(SVt_PV); - for (i = 0; i <= AvFILL(ar); i++) { - SV * const dirsv = *av_fetch(ar, i, TRUE); - - SvGETMAGIC(dirsv); - if (SvROK(dirsv)) { - int count; - SV **svp; - SV *loader = dirsv; - - if (SvTYPE(SvRV(loader)) == SVt_PVAV - && !SvOBJECT(SvRV(loader))) - { - loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE); - SvGETMAGIC(loader); - } - - Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s", - PTR2UV(SvRV(dirsv)), name); - tryname = SvPVX_const(namesv); - tryrsfp = NULL; - - if (SvPADTMP(nsv)) { - nsv = sv_newmortal(); - SvSetSV_nosteal(nsv,sv); - } - - ENTER_with_name("call_INC"); - SAVETMPS; - EXTEND(SP, 2); - - PUSHMARK(SP); - PUSHs(dirsv); - PUSHs(nsv); - PUTBACK; - if (SvGMAGICAL(loader)) { - SV *l = sv_newmortal(); - sv_setsv_nomg(l, loader); - loader = l; - } - if (sv_isobject(loader)) - count = call_method("INC", G_ARRAY); - else - count = call_sv(loader, G_ARRAY); - SPAGAIN; - - if (count > 0) { - int i = 0; - SV *arg; - - SP -= count - 1; - arg = SP[i++]; - - if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV) - && !isGV_with_GP(SvRV(arg))) { - filter_cache = SvRV(arg); - - if (i < count) { - arg = SP[i++]; - } - } - - if (SvROK(arg) && isGV_with_GP(SvRV(arg))) { - arg = SvRV(arg); - } - - if (isGV_with_GP(arg)) { - IO * const io = GvIO((const GV *)arg); - - ++filter_has_file; - - if (io) { - tryrsfp = IoIFP(io); - if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { - PerlIO_close(IoOFP(io)); - } - IoIFP(io) = NULL; - IoOFP(io) = NULL; - } - - if (i < count) { - arg = SP[i++]; - } - } - - if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { - filter_sub = arg; - SvREFCNT_inc_simple_void_NN(filter_sub); - - if (i < count) { - filter_state = SP[i]; - SvREFCNT_inc_simple_void(filter_state); - } - } - - if (!tryrsfp && (filter_cache || filter_sub)) { - tryrsfp = PerlIO_open(BIT_BUCKET, - PERL_SCRIPT_MODE); - } - SP--; - } - - /* FREETMPS may free our filter_cache */ - SvREFCNT_inc_simple_void(filter_cache); - - PUTBACK; - FREETMPS; - LEAVE_with_name("call_INC"); - - /* Now re-mortalize it. */ - sv_2mortal(filter_cache); - - /* Adjust file name if the hook has set an %INC entry. - This needs to happen after the FREETMPS above. */ - svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); - if (svp) - tryname = SvPV_nolen_const(*svp); - - if (tryrsfp) { - hook_sv = dirsv; - break; - } - - filter_has_file = 0; - filter_cache = NULL; - if (filter_state) { - SvREFCNT_dec_NN(filter_state); - filter_state = NULL; - } - if (filter_sub) { - SvREFCNT_dec_NN(filter_sub); - filter_sub = NULL; - } - } - else if (path_searchable) { + { + SV *nsv = sv; + namesv = newSV_type(SVt_PV); + for (i = 0; i <= AvFILL(ar); i++) { + SV * const dirsv = *av_fetch(ar, i, TRUE); + + SvGETMAGIC(dirsv); + if (SvROK(dirsv)) { + int count; + SV **svp; + SV *loader = dirsv; + + if (SvTYPE(SvRV(loader)) == SVt_PVAV + && !SvOBJECT(SvRV(loader))) + { + loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE); + SvGETMAGIC(loader); + } + + Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s", + PTR2UV(SvRV(dirsv)), name); + tryname = SvPVX_const(namesv); + tryrsfp = NULL; + + if (SvPADTMP(nsv)) { + nsv = sv_newmortal(); + SvSetSV_nosteal(nsv,sv); + } + + ENTER_with_name("call_INC"); + SAVETMPS; + EXTEND(SP, 2); + + PUSHMARK(SP); + PUSHs(dirsv); + PUSHs(nsv); + PUTBACK; + if (SvGMAGICAL(loader)) { + SV *l = sv_newmortal(); + sv_setsv_nomg(l, loader); + loader = l; + } + if (sv_isobject(loader)) + count = call_method("INC", G_ARRAY); + else + count = call_sv(loader, G_ARRAY); + SPAGAIN; + + if (count > 0) { + int i = 0; + SV *arg; + + SP -= count - 1; + arg = SP[i++]; + + if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV) + && !isGV_with_GP(SvRV(arg))) { + filter_cache = SvRV(arg); + + if (i < count) { + arg = SP[i++]; + } + } + + if (SvROK(arg) && isGV_with_GP(SvRV(arg))) { + arg = SvRV(arg); + } + + if (isGV_with_GP(arg)) { + IO * const io = GvIO((const GV *)arg); + + ++filter_has_file; + + if (io) { + tryrsfp = IoIFP(io); + if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { + PerlIO_close(IoOFP(io)); + } + IoIFP(io) = NULL; + IoOFP(io) = NULL; + } + + if (i < count) { + arg = SP[i++]; + } + } + + if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { + filter_sub = arg; + SvREFCNT_inc_simple_void_NN(filter_sub); + + if (i < count) { + filter_state = SP[i]; + SvREFCNT_inc_simple_void(filter_state); + } + } + + if (!tryrsfp && (filter_cache || filter_sub)) { + tryrsfp = PerlIO_open(BIT_BUCKET, + PERL_SCRIPT_MODE); + } + SP--; + } + + /* FREETMPS may free our filter_cache */ + SvREFCNT_inc_simple_void(filter_cache); + + PUTBACK; + FREETMPS; + LEAVE_with_name("call_INC"); + + /* Now re-mortalize it. */ + sv_2mortal(filter_cache); + + /* Adjust file name if the hook has set an %INC entry. + This needs to happen after the FREETMPS above. */ + svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); + if (svp) + tryname = SvPV_nolen_const(*svp); + + if (tryrsfp) { + hook_sv = dirsv; + break; + } + + filter_has_file = 0; + filter_cache = NULL; + if (filter_state) { + SvREFCNT_dec_NN(filter_state); + filter_state = NULL; + } + if (filter_sub) { + SvREFCNT_dec_NN(filter_sub); + filter_sub = NULL; + } + } + else if (path_searchable) { /* match against a plain @INC element (non-searchable * paths are only matched against refs in @INC) */ - const char *dir; - STRLEN dirlen; - - if (SvOK(dirsv)) { - dir = SvPV_nomg_const(dirsv, dirlen); - } else { - dir = ""; - dirlen = 0; - } - - if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name)) - continue; + const char *dir; + STRLEN dirlen; + + if (SvOK(dirsv)) { + dir = SvPV_nomg_const(dirsv, dirlen); + } else { + dir = ""; + dirlen = 0; + } + + if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name)) + continue; #ifdef VMS - if ((unixdir = - tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))) - == NULL) - continue; - sv_setpv(namesv, unixdir); - sv_catpv(namesv, unixname); + if ((unixdir = + tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))) + == NULL) + continue; + sv_setpv(namesv, unixdir); + sv_catpv(namesv, unixname); #else - /* The equivalent of - Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); - but without the need to parse the format string, or - call strlen on either pointer, and with the correct - allocation up front. */ - { - char *tmp = SvGROW(namesv, dirlen + len + 2); - - memcpy(tmp, dir, dirlen); - tmp +=dirlen; - - /* Avoid '<dir>//<file>' */ - if (!dirlen || *(tmp-1) != '/') { - *tmp++ = '/'; - } else { - /* So SvCUR_set reports the correct length below */ - dirlen--; - } - - /* name came from an SV, so it will have a '\0' at the - end that we can copy as part of this memcpy(). */ - memcpy(tmp, name, len + 1); - - SvCUR_set(namesv, dirlen + len + 1); - SvPOK_on(namesv); - } + /* The equivalent of + Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); + but without the need to parse the format string, or + call strlen on either pointer, and with the correct + allocation up front. */ + { + char *tmp = SvGROW(namesv, dirlen + len + 2); + + memcpy(tmp, dir, dirlen); + tmp +=dirlen; + + /* Avoid '<dir>//<file>' */ + if (!dirlen || *(tmp-1) != '/') { + *tmp++ = '/'; + } else { + /* So SvCUR_set reports the correct length below */ + dirlen--; + } + + /* name came from an SV, so it will have a '\0' at the + end that we can copy as part of this memcpy(). */ + memcpy(tmp, name, len + 1); + + SvCUR_set(namesv, dirlen + len + 1); + SvPOK_on(namesv); + } #endif - TAINT_PROPER(op_name); - tryname = SvPVX_const(namesv); - tryrsfp = doopen_pm(namesv); - if (tryrsfp) { - if (tryname[0] == '.' && tryname[1] == '/') { - ++tryname; - while (*++tryname == '/') {} - } - break; - } + TAINT_PROPER(op_name); + tryname = SvPVX_const(namesv); + tryrsfp = doopen_pm(namesv); + if (tryrsfp) { + if (tryname[0] == '.' && tryname[1] == '/') { + ++tryname; + while (*++tryname == '/') {} + } + break; + } else if (errno == EMFILE || errno == EACCES) { /* no point in trying other paths if out of handles; * on the other hand, if we couldn't open one of the @@ -4195,9 +4195,9 @@ S_require_file(pTHX_ SV *sv) */ break; } - } - } - } + } + } + } } /* at this point we've ether opened a file (tryrsfp) or set errno */ @@ -4206,24 +4206,24 @@ S_require_file(pTHX_ SV *sv) sv_2mortal(namesv); if (!tryrsfp) { /* we failed; croak if require() or return undef if do() */ - if (op_is_require) { - if(saved_errno == EMFILE || saved_errno == EACCES) { - /* diag_listed_as: Can't locate %s */ - DIE(aTHX_ "Can't locate %s: %s: %s", - name, tryname, Strerror(saved_errno)); - } else { - if (path_searchable) { /* did we lookup @INC? */ - AV * const ar = GvAVn(PL_incgv); - SSize_t i; - SV *const msg = newSVpvs_flags("", SVs_TEMP); - SV *const inc = newSVpvs_flags("", SVs_TEMP); - for (i = 0; i <= AvFILL(ar); i++) { - sv_catpvs(inc, " "); - sv_catsv(inc, *av_fetch(ar, i, TRUE)); - } - if (memENDPs(name, len, ".pm")) { + if (op_is_require) { + if(saved_errno == EMFILE || saved_errno == EACCES) { + /* diag_listed_as: Can't locate %s */ + DIE(aTHX_ "Can't locate %s: %s: %s", + name, tryname, Strerror(saved_errno)); + } else { + if (path_searchable) { /* did we lookup @INC? */ + AV * const ar = GvAVn(PL_incgv); + SSize_t i; + SV *const msg = newSVpvs_flags("", SVs_TEMP); + SV *const inc = newSVpvs_flags("", SVs_TEMP); + for (i = 0; i <= AvFILL(ar); i++) { + sv_catpvs(inc, " "); + sv_catsv(inc, *av_fetch(ar, i, TRUE)); + } + if (memENDPs(name, len, ".pm")) { const char *e = name + len - (sizeof(".pm") - 1); - const char *c; + const char *c; bool utf8 = cBOOL(SvUTF8(sv)); /* if the filename, when converted from "Foo/Bar.pm" @@ -4233,7 +4233,7 @@ S_require_file(pTHX_ SV *sv) * * this loop is modelled after the one in S_parse_ident */ - c = name; + c = name; while (c < e) { if (utf8 && isIDFIRST_utf8_safe(c, e)) { c += UTF8SKIP(c); @@ -4245,7 +4245,7 @@ S_require_file(pTHX_ SV *sv) while (c < e && isWORDCHAR_A(*c)) c++; } - else if (*c == '/') + else if (*c == '/') c++; else break; @@ -4263,22 +4263,22 @@ S_require_file(pTHX_ SV *sv) } sv_catpvs(msg, " module)"); } - } - else if (memENDs(name, len, ".h")) { - sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); - } - else if (memENDs(name, len, ".ph")) { - sv_catpvs(msg, " (did you run h2ph?)"); - } - - /* diag_listed_as: Can't locate %s */ - DIE(aTHX_ - "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")", - name, msg, inc); - } - } - DIE(aTHX_ "Can't locate %s", name); - } + } + else if (memENDs(name, len, ".h")) { + sv_catpvs(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); + } + else if (memENDs(name, len, ".ph")) { + sv_catpvs(msg, " (did you run h2ph?)"); + } + + /* diag_listed_as: Can't locate %s */ + DIE(aTHX_ + "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")", + name, msg, inc); + } + } + DIE(aTHX_ "Can't locate %s", name); + } else { #ifdef DEFAULT_INC_EXCLUDES_DOT Stat_t st; @@ -4306,19 +4306,19 @@ S_require_file(pTHX_ SV *sv) } } else - SETERRNO(0, SS_NORMAL); + SETERRNO(0, SS_NORMAL); /* Update %INC. Assume success here to prevent recursive requirement. */ /* name is never assigned to again, so len is still strlen(name) */ /* Check whether a hook in @INC has already filled %INC */ if (!hook_sv) { - (void)hv_store(GvHVn(PL_incgv), - unixname, unixlen, newSVpv(tryname,0),0); + (void)hv_store(GvHVn(PL_incgv), + unixname, unixlen, newSVpv(tryname,0),0); } else { - SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); - if (!svp) - (void)hv_store(GvHVn(PL_incgv), - unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); + SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); + if (!svp) + (void)hv_store(GvHVn(PL_incgv), + unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); } /* Now parse the file */ @@ -4329,17 +4329,17 @@ S_require_file(pTHX_ SV *sv) lex_start(NULL, tryrsfp, 0); if (filter_sub || filter_cache) { - /* We can use the SvPV of the filter PVIO itself as our cache, rather - than hanging another SV from it. In turn, filter_add() optionally - takes the SV to use as the filter (or creates a new SV if passed - NULL), so simply pass in whatever value filter_cache has. */ - SV * const fc = filter_cache ? newSV(0) : NULL; - SV *datasv; - if (fc) sv_copypv(fc, filter_cache); - datasv = filter_add(S_run_user_filter, fc); - IoLINES(datasv) = filter_has_file; - IoTOP_GV(datasv) = MUTABLE_GV(filter_state); - IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); + /* We can use the SvPV of the filter PVIO itself as our cache, rather + than hanging another SV from it. In turn, filter_add() optionally + takes the SV to use as the filter (or creates a new SV if passed + NULL), so simply pass in whatever value filter_cache has. */ + SV * const fc = filter_cache ? newSV(0) : NULL; + SV *datasv; + if (fc) sv_copypv(fc, filter_cache); + datasv = filter_add(S_run_user_filter, fc); + IoLINES(datasv) = filter_has_file; + IoTOP_GV(datasv) = MUTABLE_GV(filter_state); + IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); } /* switch to eval mode */ @@ -4353,9 +4353,9 @@ S_require_file(pTHX_ SV *sv) PUTBACK; if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL)) - op = PL_eval_start; + op = PL_eval_start; else - op = PL_op->op_next; + op = PL_op->op_next; PERL_DTRACE_PROBE_FILE_LOADED(unixname); @@ -4370,13 +4370,13 @@ PP(pp_require) RUN_PP_CATCHABLY(Perl_pp_require); { - dSP; - SV *sv = POPs; - SvGETMAGIC(sv); - PUTBACK; - return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) - ? S_require_version(aTHX_ sv) - : S_require_file(aTHX_ sv); + dSP; + SV *sv = POPs; + SvGETMAGIC(sv); + PUTBACK; + return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) + ? S_require_version(aTHX_ sv) + : S_require_file(aTHX_ sv); } } @@ -4421,36 +4421,36 @@ PP(pp_entereval) bytes = PL_op->op_private & OPpEVAL_BYTES; if (PL_op->op_private & OPpEVAL_HAS_HH) { - saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); + saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); } else if (PL_hints & HINT_LOCALIZE_HH || ( - PL_op->op_private & OPpEVAL_COPHH - && PL_curcop->cop_hints & HINT_LOCALIZE_HH - )) { - saved_hh = cop_hints_2hv(PL_curcop, 0); - hv_magic(saved_hh, NULL, PERL_MAGIC_hints); + PL_op->op_private & OPpEVAL_COPHH + && PL_curcop->cop_hints & HINT_LOCALIZE_HH + )) { + saved_hh = cop_hints_2hv(PL_curcop, 0); + hv_magic(saved_hh, NULL, PERL_MAGIC_hints); } sv = POPs; if (!SvPOK(sv)) { - /* make sure we've got a plain PV (no overload etc) before testing - * for taint. Making a copy here is probably overkill, but better - * safe than sorry */ - STRLEN len; - const char * const p = SvPV_const(sv, len); + /* make sure we've got a plain PV (no overload etc) before testing + * for taint. Making a copy here is probably overkill, but better + * safe than sorry */ + STRLEN len; + const char * const p = SvPV_const(sv, len); - sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv)); - lex_flags |= LEX_START_COPIED; + sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv)); + lex_flags |= LEX_START_COPIED; - if (bytes && SvUTF8(sv)) - SvPVbyte_force(sv, len); + if (bytes && SvUTF8(sv)) + SvPVbyte_force(sv, len); } else if (bytes && SvUTF8(sv)) { - /* Don't modify someone else's scalar */ - STRLEN len; - sv = newSVsv(sv); - (void)sv_2mortal(sv); - SvPVbyte_force(sv,len); - lex_flags |= LEX_START_COPIED; + /* Don't modify someone else's scalar */ + STRLEN len; + sv = newSVsv(sv); + (void)sv_2mortal(sv); + SvPVbyte_force(sv,len); + lex_flags |= LEX_START_COPIED; } TAINT_IF(SvTAINTED(sv)); @@ -4459,23 +4459,23 @@ PP(pp_entereval) old_savestack_ix = PL_savestack_ix; lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE - ? LEX_IGNORE_UTF8_HINTS - : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER - ) - ); + ? LEX_IGNORE_UTF8_HINTS + : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER + ) + ); /* switch to eval mode */ if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { - SV * const temp_sv = sv_newmortal(); - Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]", - (unsigned long)++PL_evalseq, - CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); - tmpbuf = SvPVX(temp_sv); - len = SvCUR(temp_sv); + SV * const temp_sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]", + (unsigned long)++PL_evalseq, + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + tmpbuf = SvPVX(temp_sv); + len = SvCUR(temp_sv); } else - len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq); + len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq); SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); @@ -4494,41 +4494,41 @@ PP(pp_entereval) /* prepare to compile string */ if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash) - save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); + save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); else { - /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up - deleting the eval's FILEGV from the stash before gv_check() runs - (i.e. before run-time proper). To work around the coredump that - ensues, we always turn GvMULTI_on for any globals that were - introduced within evals. See force_ident(). GSAR 96-10-12 */ - char *const safestr = savepvn(tmpbuf, len); - SAVEDELETE(PL_defstash, safestr, len); - saved_delete = TRUE; + /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up + deleting the eval's FILEGV from the stash before gv_check() runs + (i.e. before run-time proper). To work around the coredump that + ensues, we always turn GvMULTI_on for any globals that were + introduced within evals. See force_ident(). GSAR 96-10-12 */ + char *const safestr = savepvn(tmpbuf, len); + SAVEDELETE(PL_defstash, safestr, len); + saved_delete = TRUE; } PUTBACK; if (doeval_compile(gimme, runcv, seq, saved_hh)) { - if (was != PL_breakable_sub_gen /* Some subs defined here. */ - ? PERLDB_LINE_OR_SAVESRC - : PERLDB_SAVESRC_NOSUBS) { - /* Retain the filegv we created. */ - } else if (!saved_delete) { - char *const safestr = savepvn(tmpbuf, len); - SAVEDELETE(PL_defstash, safestr, len); - } - return PL_eval_start; + if (was != PL_breakable_sub_gen /* Some subs defined here. */ + ? PERLDB_LINE_OR_SAVESRC + : PERLDB_SAVESRC_NOSUBS) { + /* Retain the filegv we created. */ + } else if (!saved_delete) { + char *const safestr = savepvn(tmpbuf, len); + SAVEDELETE(PL_defstash, safestr, len); + } + return PL_eval_start; } else { - /* We have already left the scope set up earlier thanks to the LEAVE - in doeval_compile(). */ - if (was != PL_breakable_sub_gen /* Some subs defined here. */ - ? PERLDB_LINE_OR_SAVESRC - : PERLDB_SAVESRC_INVALID) { - /* Retain the filegv we created. */ - } else if (!saved_delete) { - (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD); - } - return PL_op->op_next; + /* We have already left the scope set up earlier thanks to the LEAVE + in doeval_compile(). */ + if (was != PL_breakable_sub_gen /* Some subs defined here. */ + ? PERLDB_LINE_OR_SAVESRC + : PERLDB_SAVESRC_INVALID) { + /* Retain the filegv we created. */ + } else if (!saved_delete) { + (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD); + } + return PL_op->op_next; } } @@ -4599,7 +4599,7 @@ void Perl_delete_eval_scope(pTHX) { PERL_CONTEXT *cx; - + cx = CX_CUR(); CX_LEAVE_SCOPE(cx); cx_popeval(cx); @@ -4614,18 +4614,18 @@ Perl_create_eval_scope(pTHX_ OP *retop, U32 flags) { PERL_CONTEXT *cx; const U8 gimme = GIMME_V; - + cx = cx_pushblock((CXt_EVAL|CXp_TRYBLOCK), gimme, PL_stack_sp, PL_savestack_ix); cx_pusheval(cx, retop, NULL); PL_in_eval = EVAL_INEVAL; if (flags & G_KEEPERR) - PL_in_eval |= EVAL_KEEPERR; + PL_in_eval |= EVAL_KEEPERR; else - CLEAR_ERRSV(); + CLEAR_ERRSV(); if (flags & G_FAKINGEVAL) { - PL_eval_root = PL_op; /* Only needed so that goto works right. */ + PL_eval_root = PL_op; /* Only needed so that goto works right. */ } } @@ -4781,30 +4781,30 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) /* Take care only to invoke mg_get() once for each argument. * Currently we do this by copying the SV if it's magical. */ if (d) { - if (!copied && SvGMAGICAL(d)) - d = sv_mortalcopy(d); + if (!copied && SvGMAGICAL(d)) + d = sv_mortalcopy(d); } else - d = &PL_sv_undef; + d = &PL_sv_undef; assert(e); if (SvGMAGICAL(e)) - e = sv_mortalcopy(e); + e = sv_mortalcopy(e); /* First of all, handle overload magic of the rightmost argument */ if (SvAMAGIC(e)) { - SV * tmpsv; - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); - DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); + SV * tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); - tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft); - if (tmpsv) { - SPAGAIN; - (void)POPs; - SETs(tmpsv); - RETURN; - } - DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); + tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft); + if (tmpsv) { + SPAGAIN; + (void)POPs; + SETs(tmpsv); + RETURN; + } + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); } SP -= 2; /* Pop the values */ @@ -4812,433 +4812,433 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied) /* ~~ undef */ if (!SvOK(e)) { - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); - if (SvOK(d)) - RETPUSHNO; - else - RETPUSHYES; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); + if (SvOK(d)) + RETPUSHNO; + else + RETPUSHYES; } if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); - Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); + Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); } if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) - object_on_left = TRUE; + object_on_left = TRUE; /* ~~ sub */ if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) { - I32 c; - if (object_on_left) { - goto sm_any_sub; /* Treat objects like scalars */ - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { - /* Test sub truth for each key */ - HE *he; - bool andedresults = TRUE; - HV *hv = (HV*) SvRV(d); - I32 numkeys = hv_iterinit(hv); - DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); - if (numkeys == 0) - RETPUSHYES; - while ( (he = hv_iternext(hv)) ) { - DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); - ENTER_with_name("smartmatch_hash_key_test"); - SAVETMPS; - PUSHMARK(SP); - PUSHs(hv_iterkeysv(he)); - PUTBACK; - c = call_sv(e, G_SCALAR); - SPAGAIN; - if (c == 0) - andedresults = FALSE; - else - andedresults = SvTRUEx(POPs) && andedresults; - FREETMPS; - LEAVE_with_name("smartmatch_hash_key_test"); - } - if (andedresults) - RETPUSHYES; - else - RETPUSHNO; - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { - /* Test sub truth for each element */ - Size_t i; - bool andedresults = TRUE; - AV *av = (AV*) SvRV(d); - const Size_t len = av_count(av); - DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); - if (len == 0) - RETPUSHYES; - for (i = 0; i < len; ++i) { - SV * const * const svp = av_fetch(av, i, FALSE); - DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); - ENTER_with_name("smartmatch_array_elem_test"); - SAVETMPS; - PUSHMARK(SP); - if (svp) - PUSHs(*svp); - PUTBACK; - c = call_sv(e, G_SCALAR); - SPAGAIN; - if (c == 0) - andedresults = FALSE; - else - andedresults = SvTRUEx(POPs) && andedresults; - FREETMPS; - LEAVE_with_name("smartmatch_array_elem_test"); - } - if (andedresults) - RETPUSHYES; - else - RETPUSHNO; - } - else { - sm_any_sub: - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); - ENTER_with_name("smartmatch_coderef"); - SAVETMPS; - PUSHMARK(SP); - PUSHs(d); - PUTBACK; - c = call_sv(e, G_SCALAR); - SPAGAIN; - if (c == 0) - PUSHs(&PL_sv_no); - else if (SvTEMP(TOPs)) - SvREFCNT_inc_void(TOPs); - FREETMPS; - LEAVE_with_name("smartmatch_coderef"); - RETURN; - } + I32 c; + if (object_on_left) { + goto sm_any_sub; /* Treat objects like scalars */ + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + /* Test sub truth for each key */ + HE *he; + bool andedresults = TRUE; + HV *hv = (HV*) SvRV(d); + I32 numkeys = hv_iterinit(hv); + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); + if (numkeys == 0) + RETPUSHYES; + while ( (he = hv_iternext(hv)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); + ENTER_with_name("smartmatch_hash_key_test"); + SAVETMPS; + PUSHMARK(SP); + PUSHs(hv_iterkeysv(he)); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + andedresults = FALSE; + else + andedresults = SvTRUEx(POPs) && andedresults; + FREETMPS; + LEAVE_with_name("smartmatch_hash_key_test"); + } + if (andedresults) + RETPUSHYES; + else + RETPUSHNO; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + /* Test sub truth for each element */ + Size_t i; + bool andedresults = TRUE; + AV *av = (AV*) SvRV(d); + const Size_t len = av_count(av); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); + if (len == 0) + RETPUSHYES; + for (i = 0; i < len; ++i) { + SV * const * const svp = av_fetch(av, i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); + ENTER_with_name("smartmatch_array_elem_test"); + SAVETMPS; + PUSHMARK(SP); + if (svp) + PUSHs(*svp); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + andedresults = FALSE; + else + andedresults = SvTRUEx(POPs) && andedresults; + FREETMPS; + LEAVE_with_name("smartmatch_array_elem_test"); + } + if (andedresults) + RETPUSHYES; + else + RETPUSHNO; + } + else { + sm_any_sub: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); + ENTER_with_name("smartmatch_coderef"); + SAVETMPS; + PUSHMARK(SP); + PUSHs(d); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + PUSHs(&PL_sv_no); + else if (SvTEMP(TOPs)) + SvREFCNT_inc_void(TOPs); + FREETMPS; + LEAVE_with_name("smartmatch_coderef"); + RETURN; + } } /* ~~ %hash */ else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) { - if (object_on_left) { - goto sm_any_hash; /* Treat objects like scalars */ - } - else if (!SvOK(d)) { - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); - RETPUSHNO; - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { - /* Check that the key-sets are identical */ - HE *he; - HV *other_hv = MUTABLE_HV(SvRV(d)); - bool tied; - bool other_tied; - U32 this_key_count = 0, - other_key_count = 0; - HV *hv = MUTABLE_HV(SvRV(e)); - - DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); - /* Tied hashes don't know how many keys they have. */ - tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied)); - other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)); - if (!tied ) { - if(other_tied) { - /* swap HV sides */ - HV * const temp = other_hv; - other_hv = hv; - hv = temp; - tied = TRUE; - other_tied = FALSE; - } - else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) - RETPUSHNO; - } - - /* The hashes have the same number of keys, so it suffices - to check that one is a subset of the other. */ - (void) hv_iterinit(hv); - while ( (he = hv_iternext(hv)) ) { - SV *key = hv_iterkeysv(he); - - DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); - ++ this_key_count; - - if(!hv_exists_ent(other_hv, key, 0)) { - (void) hv_iterinit(hv); /* reset iterator */ - RETPUSHNO; - } - } - - if (other_tied) { - (void) hv_iterinit(other_hv); - while ( hv_iternext(other_hv) ) - ++other_key_count; - } - else - other_key_count = HvUSEDKEYS(other_hv); - - if (this_key_count != other_key_count) - RETPUSHNO; - else - RETPUSHYES; - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { - AV * const other_av = MUTABLE_AV(SvRV(d)); - const Size_t other_len = av_count(other_av); - Size_t i; - HV *hv = MUTABLE_HV(SvRV(e)); - - DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); - for (i = 0; i < other_len; ++i) { - SV ** const svp = av_fetch(other_av, i, FALSE); - DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); - if (svp) { /* ??? When can this not happen? */ - if (hv_exists_ent(hv, *svp, 0)) - RETPUSHYES; - } - } - RETPUSHNO; - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { - DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); - sm_regex_hash: - { - PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); - HE *he; - HV *hv = MUTABLE_HV(SvRV(e)); - - (void) hv_iterinit(hv); - while ( (he = hv_iternext(hv)) ) { - DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); + if (object_on_left) { + goto sm_any_hash; /* Treat objects like scalars */ + } + else if (!SvOK(d)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); + RETPUSHNO; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + /* Check that the key-sets are identical */ + HE *he; + HV *other_hv = MUTABLE_HV(SvRV(d)); + bool tied; + bool other_tied; + U32 this_key_count = 0, + other_key_count = 0; + HV *hv = MUTABLE_HV(SvRV(e)); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); + /* Tied hashes don't know how many keys they have. */ + tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied)); + other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)); + if (!tied ) { + if(other_tied) { + /* swap HV sides */ + HV * const temp = other_hv; + other_hv = hv; + hv = temp; + tied = TRUE; + other_tied = FALSE; + } + else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) + RETPUSHNO; + } + + /* The hashes have the same number of keys, so it suffices + to check that one is a subset of the other. */ + (void) hv_iterinit(hv); + while ( (he = hv_iternext(hv)) ) { + SV *key = hv_iterkeysv(he); + + DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); + ++ this_key_count; + + if(!hv_exists_ent(other_hv, key, 0)) { + (void) hv_iterinit(hv); /* reset iterator */ + RETPUSHNO; + } + } + + if (other_tied) { + (void) hv_iterinit(other_hv); + while ( hv_iternext(other_hv) ) + ++other_key_count; + } + else + other_key_count = HvUSEDKEYS(other_hv); + + if (this_key_count != other_key_count) + RETPUSHNO; + else + RETPUSHYES; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + AV * const other_av = MUTABLE_AV(SvRV(d)); + const Size_t other_len = av_count(other_av); + Size_t i; + HV *hv = MUTABLE_HV(SvRV(e)); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); + for (i = 0; i < other_len; ++i) { + SV ** const svp = av_fetch(other_av, i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); + if (svp) { /* ??? When can this not happen? */ + if (hv_exists_ent(hv, *svp, 0)) + RETPUSHYES; + } + } + RETPUSHNO; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); + sm_regex_hash: + { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); + HE *he; + HV *hv = MUTABLE_HV(SvRV(e)); + + (void) hv_iterinit(hv); + while ( (he = hv_iternext(hv)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); PUTBACK; - if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { + if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { SPAGAIN; - (void) hv_iterinit(hv); - destroy_matcher(matcher); - RETPUSHYES; - } + (void) hv_iterinit(hv); + destroy_matcher(matcher); + RETPUSHYES; + } SPAGAIN; - } - destroy_matcher(matcher); - RETPUSHNO; - } - } - else { - sm_any_hash: - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); - if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) - RETPUSHYES; - else - RETPUSHNO; - } + } + destroy_matcher(matcher); + RETPUSHNO; + } + } + else { + sm_any_hash: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); + if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) + RETPUSHYES; + else + RETPUSHNO; + } } /* ~~ @array */ else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) { - if (object_on_left) { - goto sm_any_array; /* Treat objects like scalars */ - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { - AV * const other_av = MUTABLE_AV(SvRV(e)); - const Size_t other_len = av_count(other_av); - Size_t i; - - DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); - for (i = 0; i < other_len; ++i) { - SV ** const svp = av_fetch(other_av, i, FALSE); - - DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); - if (svp) { /* ??? When can this not happen? */ - if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) - RETPUSHYES; - } - } - RETPUSHNO; - } - if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { - AV *other_av = MUTABLE_AV(SvRV(d)); - DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); - if (av_count(MUTABLE_AV(SvRV(e))) != av_count(other_av)) - RETPUSHNO; - else { + if (object_on_left) { + goto sm_any_array; /* Treat objects like scalars */ + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + AV * const other_av = MUTABLE_AV(SvRV(e)); + const Size_t other_len = av_count(other_av); + Size_t i; + + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); + for (i = 0; i < other_len; ++i) { + SV ** const svp = av_fetch(other_av, i, FALSE); + + DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); + if (svp) { /* ??? When can this not happen? */ + if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) + RETPUSHYES; + } + } + RETPUSHNO; + } + if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + AV *other_av = MUTABLE_AV(SvRV(d)); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); + if (av_count(MUTABLE_AV(SvRV(e))) != av_count(other_av)) + RETPUSHNO; + else { Size_t i; const Size_t other_len = av_count(other_av); - if (NULL == seen_this) { - seen_this = newHV(); - (void) sv_2mortal(MUTABLE_SV(seen_this)); - } - if (NULL == seen_other) { - seen_other = newHV(); - (void) sv_2mortal(MUTABLE_SV(seen_other)); - } - for(i = 0; i < other_len; ++i) { - SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); - SV * const * const other_elem = av_fetch(other_av, i, FALSE); - - if (!this_elem || !other_elem) { - if ((this_elem && SvOK(*this_elem)) - || (other_elem && SvOK(*other_elem))) - RETPUSHNO; - } - else if (hv_exists_ent(seen_this, - sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) || - hv_exists_ent(seen_other, - sv_2mortal(newSViv(PTR2IV(*other_elem))), 0)) - { - if (*this_elem != *other_elem) - RETPUSHNO; - } - else { - (void)hv_store_ent(seen_this, - sv_2mortal(newSViv(PTR2IV(*this_elem))), - &PL_sv_undef, 0); - (void)hv_store_ent(seen_other, - sv_2mortal(newSViv(PTR2IV(*other_elem))), - &PL_sv_undef, 0); - PUSHs(*other_elem); - PUSHs(*this_elem); - - PUTBACK; - DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); - (void) do_smartmatch(seen_this, seen_other, 0); - SPAGAIN; - DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); - - if (!SvTRUEx(POPs)) - RETPUSHNO; - } - } - RETPUSHYES; - } - } - else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { - DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); - sm_regex_array: - { - PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); - const Size_t this_len = av_count(MUTABLE_AV(SvRV(e))); - Size_t i; - - for(i = 0; i < this_len; ++i) { - SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); - DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); + if (NULL == seen_this) { + seen_this = newHV(); + (void) sv_2mortal(MUTABLE_SV(seen_this)); + } + if (NULL == seen_other) { + seen_other = newHV(); + (void) sv_2mortal(MUTABLE_SV(seen_other)); + } + for(i = 0; i < other_len; ++i) { + SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + SV * const * const other_elem = av_fetch(other_av, i, FALSE); + + if (!this_elem || !other_elem) { + if ((this_elem && SvOK(*this_elem)) + || (other_elem && SvOK(*other_elem))) + RETPUSHNO; + } + else if (hv_exists_ent(seen_this, + sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) || + hv_exists_ent(seen_other, + sv_2mortal(newSViv(PTR2IV(*other_elem))), 0)) + { + if (*this_elem != *other_elem) + RETPUSHNO; + } + else { + (void)hv_store_ent(seen_this, + sv_2mortal(newSViv(PTR2IV(*this_elem))), + &PL_sv_undef, 0); + (void)hv_store_ent(seen_other, + sv_2mortal(newSViv(PTR2IV(*other_elem))), + &PL_sv_undef, 0); + PUSHs(*other_elem); + PUSHs(*this_elem); + + PUTBACK; + DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); + (void) do_smartmatch(seen_this, seen_other, 0); + SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); + + if (!SvTRUEx(POPs)) + RETPUSHNO; + } + } + RETPUSHYES; + } + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); + sm_regex_array: + { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); + const Size_t this_len = av_count(MUTABLE_AV(SvRV(e))); + Size_t i; + + for(i = 0; i < this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); PUTBACK; - if (svp && matcher_matches_sv(matcher, *svp)) { + if (svp && matcher_matches_sv(matcher, *svp)) { SPAGAIN; - destroy_matcher(matcher); - RETPUSHYES; - } + destroy_matcher(matcher); + RETPUSHYES; + } + SPAGAIN; + } + destroy_matcher(matcher); + RETPUSHNO; + } + } + else if (!SvOK(d)) { + /* undef ~~ array */ + const Size_t this_len = av_count(MUTABLE_AV(SvRV(e))); + Size_t i; + + DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); + for (i = 0; i < this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n")); + if (!svp || !SvOK(*svp)) + RETPUSHYES; + } + RETPUSHNO; + } + else { + sm_any_array: + { + Size_t i; + const Size_t this_len = av_count(MUTABLE_AV(SvRV(e))); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); + for (i = 0; i < this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + if (!svp) + continue; + + PUSHs(d); + PUSHs(*svp); + PUTBACK; + /* infinite recursion isn't supposed to happen here */ + DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); + (void) do_smartmatch(NULL, NULL, 1); SPAGAIN; - } - destroy_matcher(matcher); - RETPUSHNO; - } - } - else if (!SvOK(d)) { - /* undef ~~ array */ - const Size_t this_len = av_count(MUTABLE_AV(SvRV(e))); - Size_t i; - - DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); - for (i = 0; i < this_len; ++i) { - SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); - DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n")); - if (!svp || !SvOK(*svp)) - RETPUSHYES; - } - RETPUSHNO; - } - else { - sm_any_array: - { - Size_t i; - const Size_t this_len = av_count(MUTABLE_AV(SvRV(e))); - - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); - for (i = 0; i < this_len; ++i) { - SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); - if (!svp) - continue; - - PUSHs(d); - PUSHs(*svp); - PUTBACK; - /* infinite recursion isn't supposed to happen here */ - DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); - (void) do_smartmatch(NULL, NULL, 1); - SPAGAIN; - DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); - if (SvTRUEx(POPs)) - RETPUSHYES; - } - RETPUSHNO; - } - } + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); + if (SvTRUEx(POPs)) + RETPUSHYES; + } + RETPUSHNO; + } + } } /* ~~ qr// */ else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) { - if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { - SV *t = d; d = e; e = t; - DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); - goto sm_regex_hash; - } - else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { - SV *t = d; d = e; e = t; - DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); - goto sm_regex_array; - } - else { - PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); + if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + SV *t = d; d = e; e = t; + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); + goto sm_regex_hash; + } + else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + SV *t = d; d = e; e = t; + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); + goto sm_regex_array; + } + else { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); bool result; - DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); - PUTBACK; - result = matcher_matches_sv(matcher, d); + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); + PUTBACK; + result = matcher_matches_sv(matcher, d); SPAGAIN; - PUSHs(result ? &PL_sv_yes : &PL_sv_no); - destroy_matcher(matcher); - RETURN; - } + PUSHs(result ? &PL_sv_yes : &PL_sv_no); + destroy_matcher(matcher); + RETURN; + } } /* ~~ scalar */ /* See if there is overload magic on left */ else if (object_on_left && SvAMAGIC(d)) { - SV *tmpsv; - DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); - DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); - PUSHs(d); PUSHs(e); - PUTBACK; - tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); - if (tmpsv) { - SPAGAIN; - (void)POPs; - SETs(tmpsv); - RETURN; - } - SP -= 2; - DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); - goto sm_any_scalar; + SV *tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); + PUSHs(d); PUSHs(e); + PUTBACK; + tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); + if (tmpsv) { + SPAGAIN; + (void)POPs; + SETs(tmpsv); + RETURN; + } + SP -= 2; + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); + goto sm_any_scalar; } else if (!SvOK(d)) { - /* undef ~~ scalar ; we already know that the scalar is SvOK */ - DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); - RETPUSHNO; + /* undef ~~ scalar ; we already know that the scalar is SvOK */ + DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); + RETPUSHNO; } else sm_any_scalar: if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) { - DEBUG_M(if (SvNIOK(e)) - Perl_deb(aTHX_ " applying rule Any-Num\n"); - else - Perl_deb(aTHX_ " applying rule Num-numish\n"); - ); - /* numeric comparison */ - PUSHs(d); PUSHs(e); - PUTBACK; - if (CopHINTS_get(PL_curcop) & HINT_INTEGER) - (void) Perl_pp_i_eq(aTHX); - else - (void) Perl_pp_eq(aTHX); - SPAGAIN; - if (SvTRUEx(POPs)) - RETPUSHYES; - else - RETPUSHNO; + DEBUG_M(if (SvNIOK(e)) + Perl_deb(aTHX_ " applying rule Any-Num\n"); + else + Perl_deb(aTHX_ " applying rule Num-numish\n"); + ); + /* numeric comparison */ + PUSHs(d); PUSHs(e); + PUTBACK; + if (CopHINTS_get(PL_curcop) & HINT_INTEGER) + (void) Perl_pp_i_eq(aTHX); + else + (void) Perl_pp_eq(aTHX); + SPAGAIN; + if (SvTRUEx(POPs)) + RETPUSHYES; + else + RETPUSHNO; } /* As a last resort, use string comparison */ @@ -5261,9 +5261,9 @@ PP(pp_enterwhen) RETURNOP calls PUTBACK which restores the stack pointer after the POPs. */ if (!(PL_op->op_flags & OPf_SPECIAL) && !SvTRUEx(POPs)) { - if (gimme == G_SCALAR) - PUSHs(&PL_sv_undef); - RETURNOP(cLOGOP->op_other->op_next); + if (gimme == G_SCALAR) + PUSHs(&PL_sv_undef); + RETURNOP(cLOGOP->op_other->op_next); } cx = cx_pushblock(CXt_WHEN, gimme, SP, PL_savestack_ix); @@ -5285,9 +5285,9 @@ PP(pp_leavewhen) cxix = dopoptogivenfor(cxstack_ix); if (cxix < 0) - /* diag_listed_as: Can't "when" outside a topicalizer */ - DIE(aTHX_ "Can't \"%s\" outside a topicalizer", - PL_op->op_flags & OPf_SPECIAL ? "default" : "when"); + /* diag_listed_as: Can't "when" outside a topicalizer */ + DIE(aTHX_ "Can't \"%s\" outside a topicalizer", + PL_op->op_flags & OPf_SPECIAL ? "default" : "when"); oldsp = PL_stack_base + cx->blk_oldsp; if (gimme == G_VOID) @@ -5305,14 +5305,14 @@ PP(pp_leavewhen) /* emulate pp_next. Note that any stack(s) cleanup will be * done by the pp_unstack which op_nextop should point to */ cx = CX_CUR(); - cx_topblock(cx); - PL_curcop = cx->blk_oldcop; - return cx->blk_loop.my_op->op_nextop; + cx_topblock(cx); + PL_curcop = cx->blk_oldcop; + return cx->blk_loop.my_op->op_nextop; } else { - PERL_ASYNC_CHECK(); + PERL_ASYNC_CHECK(); assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN); - return cx->blk_givwhen.leave_op; + return cx->blk_givwhen.leave_op; } } @@ -5324,7 +5324,7 @@ PP(pp_continue) cxix = dopoptowhen(cxstack_ix); if (cxix < 0) - DIE(aTHX_ "Can't \"continue\" outside a when block"); + DIE(aTHX_ "Can't \"continue\" outside a when block"); if (cxix < cxstack_ix) dounwind(cxix); @@ -5348,11 +5348,11 @@ PP(pp_break) cxix = dopoptogivenfor(cxstack_ix); if (cxix < 0) - DIE(aTHX_ "Can't \"break\" outside a given block"); + DIE(aTHX_ "Can't \"break\" outside a given block"); cx = &cxstack[cxix]; if (CxFOREACH(cx)) - DIE(aTHX_ "Can't \"break\" in a loop topicalizer"); + DIE(aTHX_ "Can't \"break\" in a loop topicalizer"); if (cxix < cxstack_ix) dounwind(cxix); @@ -5388,35 +5388,35 @@ S_doparseform(pTHX_ SV *sv) PERL_ARGS_ASSERT_DOPARSEFORM; if (len == 0) - Perl_croak(aTHX_ "Null picture in formline"); + Perl_croak(aTHX_ "Null picture in formline"); if (SvTYPE(sv) >= SVt_PVMG) { - /* This might, of course, still return NULL. */ - mg = mg_find(sv, PERL_MAGIC_fm); + /* This might, of course, still return NULL. */ + mg = mg_find(sv, PERL_MAGIC_fm); } else { - sv_upgrade(sv, SVt_PVMG); + sv_upgrade(sv, SVt_PVMG); } if (mg) { - /* still the same as previously-compiled string? */ - SV *old = mg->mg_obj; - if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv)) - && len == SvCUR(old) + /* still the same as previously-compiled string? */ + SV *old = mg->mg_obj; + if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv)) + && len == SvCUR(old) && strnEQ(SvPVX(old), s, len) - ) { - DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n")); - return mg; - } + ) { + DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n")); + return mg; + } - DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n")); - Safefree(mg->mg_ptr); - mg->mg_ptr = NULL; - SvREFCNT_dec(old); - mg->mg_obj = NULL; + DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n")); + Safefree(mg->mg_ptr); + mg->mg_ptr = NULL; + SvREFCNT_dec(old); + mg->mg_obj = NULL; } else { - DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n")); - mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0); + DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n")); + mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0); } sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv)); @@ -5426,8 +5426,8 @@ S_doparseform(pTHX_ SV *sv) /* estimate the buffer size needed */ for (base = s; s <= send; s++) { - if (*s == '\n' || *s == '@' || *s == '^') - maxops += 10; + if (*s == '\n' || *s == '@' || *s == '^') + maxops += 10; } s = base; base = NULL; @@ -5436,117 +5436,117 @@ S_doparseform(pTHX_ SV *sv) fpc = fops; if (s < send) { - linepc = fpc; - *fpc++ = FF_LINEMARK; - noblank = repeat = FALSE; - base = s; + linepc = fpc; + *fpc++ = FF_LINEMARK; + noblank = repeat = FALSE; + base = s; } while (s <= send) { - switch (*s++) { - default: - skipspaces = 0; - continue; - - case '~': - if (*s == '~') { - repeat = TRUE; - skipspaces++; - s++; - } - noblank = TRUE; - /* FALLTHROUGH */ - case ' ': case '\t': - skipspaces++; - continue; + switch (*s++) { + default: + skipspaces = 0; + continue; + + case '~': + if (*s == '~') { + repeat = TRUE; + skipspaces++; + s++; + } + noblank = TRUE; + /* FALLTHROUGH */ + case ' ': case '\t': + skipspaces++; + continue; case 0: - if (s < send) { - skipspaces = 0; + if (s < send) { + skipspaces = 0; continue; } /* FALLTHROUGH */ - case '\n': - arg = s - base; - skipspaces++; - arg -= skipspaces; - if (arg) { - if (postspace) - *fpc++ = FF_SPACE; - *fpc++ = FF_LITERAL; - *fpc++ = (U32)arg; - } - postspace = FALSE; - if (s <= send) - skipspaces--; - if (skipspaces) { - *fpc++ = FF_SKIP; - *fpc++ = (U32)skipspaces; - } - skipspaces = 0; - if (s <= send) - *fpc++ = FF_NEWLINE; - if (noblank) { - *fpc++ = FF_BLANK; - if (repeat) - arg = fpc - linepc + 1; - else - arg = 0; - *fpc++ = (U32)arg; - } - if (s < send) { - linepc = fpc; - *fpc++ = FF_LINEMARK; - noblank = repeat = FALSE; - base = s; - } - else - s++; - continue; - - case '@': - case '^': - ischop = s[-1] == '^'; - - if (postspace) { - *fpc++ = FF_SPACE; - postspace = FALSE; - } - arg = (s - base) - 1; - if (arg) { - *fpc++ = FF_LITERAL; - *fpc++ = (U32)arg; - } - - base = s - 1; - *fpc++ = FF_FETCH; - if (*s == '*') { /* @* or ^* */ - s++; - *fpc++ = 2; /* skip the @* or ^* */ - if (ischop) { - *fpc++ = FF_LINESNGL; - *fpc++ = FF_CHOP; - } else - *fpc++ = FF_LINEGLOB; - } - else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */ - arg = ischop ? FORM_NUM_BLANK : 0; - base = s - 1; - while (*s == '#') - s++; - if (*s == '.') { + case '\n': + arg = s - base; + skipspaces++; + arg -= skipspaces; + if (arg) { + if (postspace) + *fpc++ = FF_SPACE; + *fpc++ = FF_LITERAL; + *fpc++ = (U32)arg; + } + postspace = FALSE; + if (s <= send) + skipspaces--; + if (skipspaces) { + *fpc++ = FF_SKIP; + *fpc++ = (U32)skipspaces; + } + skipspaces = 0; + if (s <= send) + *fpc++ = FF_NEWLINE; + if (noblank) { + *fpc++ = FF_BLANK; + if (repeat) + arg = fpc - linepc + 1; + else + arg = 0; + *fpc++ = (U32)arg; + } + if (s < send) { + linepc = fpc; + *fpc++ = FF_LINEMARK; + noblank = repeat = FALSE; + base = s; + } + else + s++; + continue; + + case '@': + case '^': + ischop = s[-1] == '^'; + + if (postspace) { + *fpc++ = FF_SPACE; + postspace = FALSE; + } + arg = (s - base) - 1; + if (arg) { + *fpc++ = FF_LITERAL; + *fpc++ = (U32)arg; + } + + base = s - 1; + *fpc++ = FF_FETCH; + if (*s == '*') { /* @* or ^* */ + s++; + *fpc++ = 2; /* skip the @* or ^* */ + if (ischop) { + *fpc++ = FF_LINESNGL; + *fpc++ = FF_CHOP; + } else + *fpc++ = FF_LINEGLOB; + } + else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */ + arg = ischop ? FORM_NUM_BLANK : 0; + base = s - 1; + while (*s == '#') + s++; + if (*s == '.') { const char * const f = ++s; - while (*s == '#') - s++; - arg |= FORM_NUM_POINT + (s - f); - } - *fpc++ = s - base; /* fieldsize for FETCH */ - *fpc++ = FF_DECIMAL; + while (*s == '#') + s++; + arg |= FORM_NUM_POINT + (s - f); + } + *fpc++ = s - base; /* fieldsize for FETCH */ + *fpc++ = FF_DECIMAL; *fpc++ = (U32)arg; unchopnum |= ! ischop; } else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */ arg = ischop ? FORM_NUM_BLANK : 0; - base = s - 1; + base = s - 1; s++; /* skip the '0' first */ while (*s == '#') s++; @@ -5558,47 +5558,47 @@ S_doparseform(pTHX_ SV *sv) } *fpc++ = s - base; /* fieldsize for FETCH */ *fpc++ = FF_0DECIMAL; - *fpc++ = (U32)arg; + *fpc++ = (U32)arg; unchopnum |= ! ischop; - } - else { /* text field */ - I32 prespace = 0; - bool ismore = FALSE; - - if (*s == '>') { - while (*++s == '>') ; - prespace = FF_SPACE; - } - else if (*s == '|') { - while (*++s == '|') ; - prespace = FF_HALFSPACE; - postspace = TRUE; - } - else { - if (*s == '<') - while (*++s == '<') ; - postspace = TRUE; - } - if (*s == '.' && s[1] == '.' && s[2] == '.') { - s += 3; - ismore = TRUE; - } - *fpc++ = s - base; /* fieldsize for FETCH */ - - *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; - - if (prespace) - *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */ - *fpc++ = FF_ITEM; - if (ismore) - *fpc++ = FF_MORE; - if (ischop) - *fpc++ = FF_CHOP; - } - base = s; - skipspaces = 0; - continue; - } + } + else { /* text field */ + I32 prespace = 0; + bool ismore = FALSE; + + if (*s == '>') { + while (*++s == '>') ; + prespace = FF_SPACE; + } + else if (*s == '|') { + while (*++s == '|') ; + prespace = FF_HALFSPACE; + postspace = TRUE; + } + else { + if (*s == '<') + while (*++s == '<') ; + postspace = TRUE; + } + if (*s == '.' && s[1] == '.' && s[2] == '.') { + s += 3; + ismore = TRUE; + } + *fpc++ = s - base; /* fieldsize for FETCH */ + + *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; + + if (prespace) + *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */ + *fpc++ = FF_ITEM; + if (ismore) + *fpc++ = FF_MORE; + if (ischop) + *fpc++ = FF_CHOP; + } + base = s; + skipspaces = 0; + continue; + } } *fpc++ = FF_END; @@ -5636,10 +5636,10 @@ S_num_overflow(NV value, I32 fldsize, I32 frcsize) if( value >= 0 ){ if (value + eps >= pwr) - res = TRUE; + res = TRUE; } else { if (value - eps <= -pwr) - res = TRUE; + res = TRUE; } return res; } @@ -5671,41 +5671,41 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) not sure where the trouble is yet. XXX */ { - SV *const cache = datasv; - if (SvOK(cache)) { - STRLEN cache_len; - const char *cache_p = SvPV(cache, cache_len); - STRLEN take = 0; - - if (umaxlen) { - /* Running in block mode and we have some cached data already. - */ - if (cache_len >= umaxlen) { - /* In fact, so much data we don't even need to call - filter_read. */ - take = umaxlen; - } - } else { - const char *const first_nl = - (const char *)memchr(cache_p, '\n', cache_len); - if (first_nl) { - take = first_nl + 1 - cache_p; - } - } - if (take) { - sv_catpvn(buf_sv, cache_p, take); - sv_chop(cache, cache_p + take); - /* Definitely not EOF */ - return 1; - } - - sv_catsv(buf_sv, cache); - if (umaxlen) { - umaxlen -= cache_len; - } - SvOK_off(cache); - read_from_cache = TRUE; - } + SV *const cache = datasv; + if (SvOK(cache)) { + STRLEN cache_len; + const char *cache_p = SvPV(cache, cache_len); + STRLEN take = 0; + + if (umaxlen) { + /* Running in block mode and we have some cached data already. + */ + if (cache_len >= umaxlen) { + /* In fact, so much data we don't even need to call + filter_read. */ + take = umaxlen; + } + } else { + const char *const first_nl = + (const char *)memchr(cache_p, '\n', cache_len); + if (first_nl) { + take = first_nl + 1 - cache_p; + } + } + if (take) { + sv_catpvn(buf_sv, cache_p, take); + sv_chop(cache, cache_p + take); + /* Definitely not EOF */ + return 1; + } + + sv_catsv(buf_sv, cache); + if (umaxlen) { + umaxlen -= cache_len; + } + SvOK_off(cache); + read_from_cache = TRUE; + } } /* Filter API says that the filter appends to the contents of the buffer. @@ -5714,97 +5714,97 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) don't want to pass it in a second time. I'm going to use a mortal in case the upstream filter croaks. */ upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv)) - ? sv_newmortal() : buf_sv; + ? sv_newmortal() : buf_sv; SvUPGRADE(upstream, SVt_PV); - + if (filter_has_file) { - status = FILTER_READ(idx+1, upstream, 0); + status = FILTER_READ(idx+1, upstream, 0); } if (filter_sub && status >= 0) { - dSP; - int count; - - ENTER_with_name("call_filter_sub"); - SAVE_DEFSV; - SAVETMPS; - EXTEND(SP, 2); - - DEFSV_set(upstream); - PUSHMARK(SP); - PUSHs(&PL_sv_zero); - if (filter_state) { - PUSHs(filter_state); - } - PUTBACK; - count = call_sv(filter_sub, G_SCALAR|G_EVAL); - SPAGAIN; - - if (count > 0) { - SV *out = POPs; - SvGETMAGIC(out); - if (SvOK(out)) { - status = SvIV(out); - } + dSP; + int count; + + ENTER_with_name("call_filter_sub"); + SAVE_DEFSV; + SAVETMPS; + EXTEND(SP, 2); + + DEFSV_set(upstream); + PUSHMARK(SP); + PUSHs(&PL_sv_zero); + if (filter_state) { + PUSHs(filter_state); + } + PUTBACK; + count = call_sv(filter_sub, G_SCALAR|G_EVAL); + SPAGAIN; + + if (count > 0) { + SV *out = POPs; + SvGETMAGIC(out); + if (SvOK(out)) { + status = SvIV(out); + } else { SV * const errsv = ERRSV; if (SvTRUE_NN(errsv)) err = newSVsv(errsv); } - } + } - PUTBACK; - FREETMPS; - LEAVE_with_name("call_filter_sub"); + PUTBACK; + FREETMPS; + LEAVE_with_name("call_filter_sub"); } if (SvGMAGICAL(upstream)) { - mg_get(upstream); - if (upstream == buf_sv) mg_free(buf_sv); + mg_get(upstream); + if (upstream == buf_sv) mg_free(buf_sv); } if (SvIsCOW(upstream)) sv_force_normal(upstream); if(!err && SvOK(upstream)) { - got_p = SvPV_nomg(upstream, got_len); - if (umaxlen) { - if (got_len > umaxlen) { - prune_from = got_p + umaxlen; - } - } else { - char *const first_nl = (char *)memchr(got_p, '\n', got_len); - if (first_nl && first_nl + 1 < got_p + got_len) { - /* There's a second line here... */ - prune_from = first_nl + 1; - } - } + got_p = SvPV_nomg(upstream, got_len); + if (umaxlen) { + if (got_len > umaxlen) { + prune_from = got_p + umaxlen; + } + } else { + char *const first_nl = (char *)memchr(got_p, '\n', got_len); + if (first_nl && first_nl + 1 < got_p + got_len) { + /* There's a second line here... */ + prune_from = first_nl + 1; + } + } } if (!err && prune_from) { - /* Oh. Too long. Stuff some in our cache. */ - STRLEN cached_len = got_p + got_len - prune_from; - SV *const cache = datasv; - - if (SvOK(cache)) { - /* Cache should be empty. */ - assert(!SvCUR(cache)); - } - - sv_setpvn(cache, prune_from, cached_len); - /* If you ask for block mode, you may well split UTF-8 characters. - "If it breaks, you get to keep both parts" - (Your code is broken if you don't put them back together again - before something notices.) */ - if (SvUTF8(upstream)) { - SvUTF8_on(cache); - } - if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len); - else - /* Cannot just use sv_setpvn, as that could free the buffer - before we have a chance to assign it. */ - sv_usepvn(upstream, savepvn(got_p, got_len - cached_len), - got_len - cached_len); - *prune_from = 0; - /* Can't yet be EOF */ - if (status == 0) - status = 1; + /* Oh. Too long. Stuff some in our cache. */ + STRLEN cached_len = got_p + got_len - prune_from; + SV *const cache = datasv; + + if (SvOK(cache)) { + /* Cache should be empty. */ + assert(!SvCUR(cache)); + } + + sv_setpvn(cache, prune_from, cached_len); + /* If you ask for block mode, you may well split UTF-8 characters. + "If it breaks, you get to keep both parts" + (Your code is broken if you don't put them back together again + before something notices.) */ + if (SvUTF8(upstream)) { + SvUTF8_on(cache); + } + if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len); + else + /* Cannot just use sv_setpvn, as that could free the buffer + before we have a chance to assign it. */ + sv_usepvn(upstream, savepvn(got_p, got_len - cached_len), + got_len - cached_len); + *prune_from = 0; + /* Can't yet be EOF */ + if (status == 0) + status = 1; } /* If they are at EOF but buf_sv has something in it, then they may never @@ -5813,31 +5813,31 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) */ if (!err && upstream != buf_sv && SvOK(upstream)) { - sv_catsv_nomg(buf_sv, upstream); + sv_catsv_nomg(buf_sv, upstream); } else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv); if (status <= 0) { - IoLINES(datasv) = 0; - if (filter_state) { - SvREFCNT_dec(filter_state); - IoTOP_GV(datasv) = NULL; - } - if (filter_sub) { - SvREFCNT_dec(filter_sub); - IoBOTTOM_GV(datasv) = NULL; - } - filter_del(S_run_user_filter); + IoLINES(datasv) = 0; + if (filter_state) { + SvREFCNT_dec(filter_state); + IoTOP_GV(datasv) = NULL; + } + if (filter_sub) { + SvREFCNT_dec(filter_sub); + IoBOTTOM_GV(datasv) = NULL; + } + filter_del(S_run_user_filter); } if (err) croak_sv(err); if (status == 0 && read_from_cache) { - /* If we read some data from the cache (and by getting here it implies - that we emptied the cache) then we aren't yet at EOF, and mustn't - report that to our caller. */ - return 1; + /* If we read some data from the cache (and by getting here it implies + that we emptied the cache) then we aren't yet at EOF, and mustn't + report that to our caller. */ + return 1; } return status; } @@ -60,9 +60,9 @@ PP(pp_gvsv) dSP; EXTEND(SP,1); if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO)) - PUSHs(save_scalar(cGVOP_gv)); + PUSHs(save_scalar(cGVOP_gv)); else - PUSHs(GvSVn(cGVOP_gv)); + PUSHs(GvSVn(cGVOP_gv)); RETURN; } @@ -107,19 +107,19 @@ PP(pp_and) { PERL_ASYNC_CHECK(); { - /* SP is not used to remove a variable that is saved across the - sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine - register or load/store vs direct mem ops macro is introduced, this - should be a define block between direct PL_stack_sp and dSP operations, - presently, using PL_stack_sp is bias towards CISC cpus */ - SV * const sv = *PL_stack_sp; - if (!SvTRUE_NN(sv)) - return NORMAL; - else { - if (PL_op->op_type == OP_AND) - --PL_stack_sp; - return cLOGOP->op_other; - } + /* SP is not used to remove a variable that is saved across the + sv_2bool_flags call in SvTRUE_NN, if a RISC/CISC or low/high machine + register or load/store vs direct mem ops macro is introduced, this + should be a define block between direct PL_stack_sp and dSP operations, + presently, using PL_stack_sp is bias towards CISC cpus */ + SV * const sv = *PL_stack_sp; + if (!SvTRUE_NN(sv)) + return NORMAL; + else { + if (PL_op->op_type == OP_AND) + --PL_stack_sp; + return cLOGOP->op_other; + } } } @@ -132,98 +132,98 @@ PP(pp_sassign) SV *left = POPs; SV *right = TOPs; if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */ - SV * const temp = left; - left = right; right = temp; + SV * const temp = left; + left = right; right = temp; } assert(TAINTING_get || !TAINT_get); if (UNLIKELY(TAINT_get) && !SvTAINTED(right)) - TAINT_NOT; + TAINT_NOT; if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) { /* *foo =\&bar */ - SV * const cv = SvRV(right); - const U32 cv_type = SvTYPE(cv); - const bool is_gv = isGV_with_GP(left); - const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM; - - if (!got_coderef) { - assert(SvROK(cv)); - } - - /* Can do the optimisation if left (LVALUE) is not a typeglob, - right (RVALUE) is a reference to something, and we're in void - context. */ - if (!got_coderef && !is_gv && GIMME_V == G_VOID) { - /* Is the target symbol table currently empty? */ - GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV); - if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) { - /* Good. Create a new proxy constant subroutine in the target. - The gv becomes a(nother) reference to the constant. */ - SV *const value = SvRV(cv); - - SvUPGRADE(MUTABLE_SV(gv), SVt_IV); - SvPCS_IMPORTED_on(gv); - SvRV_set(gv, value); - SvREFCNT_inc_simple_void(value); - SETs(left); - RETURN; - } - } - - /* Need to fix things up. */ - if (!is_gv) { - /* Need to fix GV. */ - left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV)); - } - - if (!got_coderef) { - /* We've been returned a constant rather than a full subroutine, - but they expect a subroutine reference to apply. */ - if (SvROK(cv)) { - ENTER_with_name("sassign_coderef"); - SvREFCNT_inc_void(SvRV(cv)); - /* newCONSTSUB takes a reference count on the passed in SV - from us. We set the name to NULL, otherwise we get into - all sorts of fun as the reference to our new sub is - donated to the GV that we're about to assign to. - */ - SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL, - SvRV(cv)))); - SvREFCNT_dec_NN(cv); - LEAVE_with_name("sassign_coderef"); - } else { - /* What can happen for the corner case *{"BONK"} = \&{"BONK"}; - is that - First: ops for \&{"BONK"}; return us the constant in the - symbol table - Second: ops for *{"BONK"} cause that symbol table entry - (and our reference to it) to be upgraded from RV - to typeblob) - Thirdly: We get here. cv is actually PVGV now, and its - GvCV() is actually the subroutine we're looking for - - So change the reference so that it points to the subroutine - of that typeglob, as that's what they were after all along. - */ - GV *const upgraded = MUTABLE_GV(cv); - CV *const source = GvCV(upgraded); - - assert(source); - assert(CvFLAGS(source) & CVf_CONST); - - SvREFCNT_inc_simple_void_NN(source); - SvREFCNT_dec_NN(upgraded); - SvRV_set(right, MUTABLE_SV(source)); - } - } + SV * const cv = SvRV(right); + const U32 cv_type = SvTYPE(cv); + const bool is_gv = isGV_with_GP(left); + const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM; + + if (!got_coderef) { + assert(SvROK(cv)); + } + + /* Can do the optimisation if left (LVALUE) is not a typeglob, + right (RVALUE) is a reference to something, and we're in void + context. */ + if (!got_coderef && !is_gv && GIMME_V == G_VOID) { + /* Is the target symbol table currently empty? */ + GV * const gv = gv_fetchsv_nomg(left, GV_NOINIT, SVt_PVGV); + if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) { + /* Good. Create a new proxy constant subroutine in the target. + The gv becomes a(nother) reference to the constant. */ + SV *const value = SvRV(cv); + + SvUPGRADE(MUTABLE_SV(gv), SVt_IV); + SvPCS_IMPORTED_on(gv); + SvRV_set(gv, value); + SvREFCNT_inc_simple_void(value); + SETs(left); + RETURN; + } + } + + /* Need to fix things up. */ + if (!is_gv) { + /* Need to fix GV. */ + left = MUTABLE_SV(gv_fetchsv_nomg(left,GV_ADD, SVt_PVGV)); + } + + if (!got_coderef) { + /* We've been returned a constant rather than a full subroutine, + but they expect a subroutine reference to apply. */ + if (SvROK(cv)) { + ENTER_with_name("sassign_coderef"); + SvREFCNT_inc_void(SvRV(cv)); + /* newCONSTSUB takes a reference count on the passed in SV + from us. We set the name to NULL, otherwise we get into + all sorts of fun as the reference to our new sub is + donated to the GV that we're about to assign to. + */ + SvRV_set(right, MUTABLE_SV(newCONSTSUB(GvSTASH(left), NULL, + SvRV(cv)))); + SvREFCNT_dec_NN(cv); + LEAVE_with_name("sassign_coderef"); + } else { + /* What can happen for the corner case *{"BONK"} = \&{"BONK"}; + is that + First: ops for \&{"BONK"}; return us the constant in the + symbol table + Second: ops for *{"BONK"} cause that symbol table entry + (and our reference to it) to be upgraded from RV + to typeblob) + Thirdly: We get here. cv is actually PVGV now, and its + GvCV() is actually the subroutine we're looking for + + So change the reference so that it points to the subroutine + of that typeglob, as that's what they were after all along. + */ + GV *const upgraded = MUTABLE_GV(cv); + CV *const source = GvCV(upgraded); + + assert(source); + assert(CvFLAGS(source) & CVf_CONST); + + SvREFCNT_inc_simple_void_NN(source); + SvREFCNT_dec_NN(upgraded); + SvRV_set(right, MUTABLE_SV(source)); + } + } } if ( UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 && (!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC) ) - Perl_warner(aTHX_ - packWARN(WARN_MISC), "Useless assignment to a temporary" - ); + Perl_warner(aTHX_ + packWARN(WARN_MISC), "Useless assignment to a temporary" + ); SvSetMagicSV(left, right); SETs(left); RETURN; @@ -249,7 +249,7 @@ PP(pp_unstack) FREETMPS; if (!(PL_op->op_flags & OPf_SPECIAL)) { assert(CxTYPE(cx) == CXt_BLOCK || CxTYPE_is_LOOP(cx)); - CX_LEAVE_SCOPE(cx); + CX_LEAVE_SCOPE(cx); } return NORMAL; } @@ -272,53 +272,53 @@ S_do_concat(pTHX_ SV *left, SV *right, SV *targ, U8 targmy) bool rcopied = FALSE; if (TARG == right && right != left) { /* $r = $l.$r */ - rpv = SvPV_nomg_const(right, rlen); - rbyte = !DO_UTF8(right); - right = newSVpvn_flags(rpv, rlen, SVs_TEMP); - rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */ - rcopied = TRUE; + rpv = SvPV_nomg_const(right, rlen); + rbyte = !DO_UTF8(right); + right = newSVpvn_flags(rpv, rlen, SVs_TEMP); + rpv = SvPV_const(right, rlen); /* no point setting UTF-8 here */ + rcopied = TRUE; } if (TARG != left) { /* not $l .= $r */ STRLEN llen; const char* const lpv = SvPV_nomg_const(left, llen); - lbyte = !DO_UTF8(left); - sv_setpvn(TARG, lpv, llen); - if (!lbyte) - SvUTF8_on(TARG); - else - SvUTF8_off(TARG); + lbyte = !DO_UTF8(left); + sv_setpvn(TARG, lpv, llen); + if (!lbyte) + SvUTF8_on(TARG); + else + SvUTF8_off(TARG); } else { /* $l .= $r and left == TARG */ - if (!SvOK(left)) { + if (!SvOK(left)) { if ((left == right /* $l .= $l */ || targmy) /* $l = $l . $r */ && ckWARN(WARN_UNINITIALIZED) ) report_uninit(left); SvPVCLEAR(left); - } + } else { SvPV_force_nomg_nolen(left); } - lbyte = !DO_UTF8(left); - if (IN_BYTES) - SvUTF8_off(left); + lbyte = !DO_UTF8(left); + if (IN_BYTES) + SvUTF8_off(left); } if (!rcopied) { - rpv = SvPV_nomg_const(right, rlen); - rbyte = !DO_UTF8(right); + rpv = SvPV_nomg_const(right, rlen); + rbyte = !DO_UTF8(right); } if (lbyte != rbyte) { - if (lbyte) - sv_utf8_upgrade_nomg(TARG); - else { - if (!rcopied) - right = newSVpvn_flags(rpv, rlen, SVs_TEMP); - sv_utf8_upgrade_nomg(right); - rpv = SvPV_nomg_const(right, rlen); - } + if (lbyte) + sv_utf8_upgrade_nomg(TARG); + else { + if (!rcopied) + right = newSVpvn_flags(rpv, rlen, SVs_TEMP); + sv_utf8_upgrade_nomg(right); + rpv = SvPV_nomg_const(right, rlen); + } } sv_catpvn_nomg(TARG, rpv, rlen); SvSETMAGIC(TARG); @@ -1142,7 +1142,7 @@ S_pushav(pTHX_ AV* const av) PADOFFSET i; for (i=0; i < (PADOFFSET)maxarg; i++) { SV *sv = AvARRAY(av)[i]; - SP[i+1] = LIKELY(sv) + SP[i+1] = LIKELY(sv) ? sv : UNLIKELY(PL_op->op_flags & OPf_MOD) ? av_nonelem(av,i) @@ -1207,28 +1207,28 @@ PP(pp_padsv) dSP; EXTEND(SP, 1); { - OP * const op = PL_op; - /* access PL_curpad once */ - SV ** const padentry = &(PAD_SVl(op->op_targ)); - { - dTARG; - TARG = *padentry; - PUSHs(TARG); - PUTBACK; /* no pop/push after this, TOPs ok */ - } - if (op->op_flags & OPf_MOD) { - if (op->op_private & OPpLVAL_INTRO) - if (!(op->op_private & OPpPAD_STATE)) - save_clearsv(padentry); - if (op->op_private & OPpDEREF) { - /* TOPs is equivalent to TARG here. Using TOPs (SP) rather - than TARG reduces the scope of TARG, so it does not - span the call to save_clearsv, resulting in smaller - machine code. */ - TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF); - } - } - return op->op_next; + OP * const op = PL_op; + /* access PL_curpad once */ + SV ** const padentry = &(PAD_SVl(op->op_targ)); + { + dTARG; + TARG = *padentry; + PUSHs(TARG); + PUTBACK; /* no pop/push after this, TOPs ok */ + } + if (op->op_flags & OPf_MOD) { + if (op->op_private & OPpLVAL_INTRO) + if (!(op->op_private & OPpPAD_STATE)) + save_clearsv(padentry); + if (op->op_private & OPpDEREF) { + /* TOPs is equivalent to TARG here. Using TOPs (SP) rather + than TARG reduces the scope of TARG, so it does not + span the call to save_clearsv, resulting in smaller + machine code. */ + TOPs = vivify_ref(TOPs, op->op_private & OPpDEREF); + } + } + return op->op_next; } } @@ -1238,22 +1238,22 @@ PP(pp_readline) /* pp_coreargs pushes a NULL to indicate no args passed to * CORE::readline() */ if (TOPs) { - SvGETMAGIC(TOPs); - tryAMAGICunTARGETlist(iter_amg, 0); - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + SvGETMAGIC(TOPs); + tryAMAGICunTARGETlist(iter_amg, 0); + PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); } else PL_last_in_gv = PL_argvgv, PL_stack_sp--; if (!isGV_with_GP(PL_last_in_gv)) { - if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv))) - PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv)); - else { - dSP; - XPUSHs(MUTABLE_SV(PL_last_in_gv)); - PUTBACK; - Perl_pp_rv2gv(aTHX); - PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); + if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv))) + PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv)); + else { + dSP; + XPUSHs(MUTABLE_SV(PL_last_in_gv)); + PUTBACK; + Perl_pp_rv2gv(aTHX); + PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv)); - } + } } return do_readline(); } @@ -1293,10 +1293,10 @@ PP(pp_preinc) == SVf_IOK)) && SvIVX(sv) != IV_MAX) { - SvIV_set(sv, SvIVX(sv) + 1); + SvIV_set(sv, SvIVX(sv) + 1); } else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_inc */ - sv_inc(sv); + sv_inc(sv); SvSETMAGIC(sv); return NORMAL; } @@ -1314,10 +1314,10 @@ PP(pp_predec) == SVf_IOK)) && SvIVX(sv) != IV_MIN) { - SvIV_set(sv, SvIVX(sv) - 1); + SvIV_set(sv, SvIVX(sv) - 1); } else /* Do all the PERL_PRESERVE_IVUV and hard cases in sv_dec */ - sv_dec(sv); + sv_dec(sv); SvSETMAGIC(sv); return NORMAL; } @@ -1332,11 +1332,11 @@ PP(pp_or) PERL_ASYNC_CHECK(); sv = TOPs; if (SvTRUE_NN(sv)) - RETURN; + RETURN; else { - if (PL_op->op_type == OP_OR) + if (PL_op->op_type == OP_OR) --SP; - RETURNOP(cLOGOP->op_other); + RETURNOP(cLOGOP->op_other); } } @@ -1352,16 +1352,16 @@ PP(pp_defined) const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN); if (is_dor) { - PERL_ASYNC_CHECK(); + PERL_ASYNC_CHECK(); sv = TOPs; if (UNLIKELY(!sv || !SvANY(sv))) { - if (op_type == OP_DOR) - --SP; + if (op_type == OP_DOR) + --SP; RETURNOP(cLOGOP->op_other); } } else { - /* OP_DEFINED */ + /* OP_DEFINED */ sv = POPs; if (UNLIKELY(!sv || !SvANY(sv))) RETPUSHNO; @@ -1370,22 +1370,22 @@ PP(pp_defined) defined = FALSE; switch (SvTYPE(sv)) { case SVt_PVAV: - if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - defined = TRUE; - break; + if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) + defined = TRUE; + break; case SVt_PVHV: - if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - defined = TRUE; - break; + if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) + defined = TRUE; + break; case SVt_PVCV: - if (CvROOT(sv) || CvXSUB(sv)) - defined = TRUE; - break; + if (CvROOT(sv) || CvXSUB(sv)) + defined = TRUE; + break; default: - SvGETMAGIC(sv); - if (SvOK(sv)) - defined = TRUE; - break; + SvGETMAGIC(sv); + if (SvOK(sv)) + defined = TRUE; + break; } if (is_dor) { @@ -1503,103 +1503,103 @@ PP(pp_add) */ if (SvIV_please_nomg(svr)) { - /* Unless the left argument is integer in range we are going to have to - use NV maths. Hence only attempt to coerce the right argument if - we know the left is integer. */ - UV auv = 0; - bool auvok = FALSE; - bool a_valid = 0; - - if (!useleft) { - auv = 0; - a_valid = auvok = 1; - /* left operand is undef, treat as zero. + 0 is identity, - Could SETi or SETu right now, but space optimise by not adding - lots of code to speed up what is probably a rarish case. */ - } else { - /* Left operand is defined, so is it IV? */ - if (SvIV_please_nomg(svl)) { - if ((auvok = SvUOK(svl))) - auv = SvUVX(svl); - else { - const IV aiv = SvIVX(svl); - if (aiv >= 0) { - auv = aiv; - auvok = 1; /* Now acting as a sign flag. */ - } else { + /* Unless the left argument is integer in range we are going to have to + use NV maths. Hence only attempt to coerce the right argument if + we know the left is integer. */ + UV auv = 0; + bool auvok = FALSE; + bool a_valid = 0; + + if (!useleft) { + auv = 0; + a_valid = auvok = 1; + /* left operand is undef, treat as zero. + 0 is identity, + Could SETi or SETu right now, but space optimise by not adding + lots of code to speed up what is probably a rarish case. */ + } else { + /* Left operand is defined, so is it IV? */ + if (SvIV_please_nomg(svl)) { + if ((auvok = SvUOK(svl))) + auv = SvUVX(svl); + else { + const IV aiv = SvIVX(svl); + if (aiv >= 0) { + auv = aiv; + auvok = 1; /* Now acting as a sign flag. */ + } else { /* Using 0- here and later to silence bogus warning * from MS VC */ auv = (UV) (0 - (UV) aiv); - } - } - a_valid = 1; - } - } - if (a_valid) { - bool result_good = 0; - UV result; - UV buv; - bool buvok = SvUOK(svr); - - if (buvok) - buv = SvUVX(svr); - else { - const IV biv = SvIVX(svr); - if (biv >= 0) { - buv = biv; - buvok = 1; - } else + } + } + a_valid = 1; + } + } + if (a_valid) { + bool result_good = 0; + UV result; + UV buv; + bool buvok = SvUOK(svr); + + if (buvok) + buv = SvUVX(svr); + else { + const IV biv = SvIVX(svr); + if (biv >= 0) { + buv = biv; + buvok = 1; + } else buv = (UV) (0 - (UV) biv); - } - /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, - else "IV" now, independent of how it came in. - if a, b represents positive, A, B negative, a maps to -A etc - a + b => (a + b) - A + b => -(a - b) - a + B => (a - b) - A + B => -(a + b) - all UV maths. negate result if A negative. - add if signs same, subtract if signs differ. */ - - if (auvok ^ buvok) { - /* Signs differ. */ - if (auv >= buv) { - result = auv - buv; - /* Must get smaller */ - if (result <= auv) - result_good = 1; - } else { - result = buv - auv; - if (result <= buv) { - /* result really should be -(auv-buv). as its negation - of true value, need to swap our result flag */ - auvok = !auvok; - result_good = 1; - } - } - } else { - /* Signs same */ - result = auv + buv; - if (result >= auv) - result_good = 1; - } - if (result_good) { - SP--; - if (auvok) - SETu( result ); - else { - /* Negate result */ - if (result <= (UV)IV_MIN) + } + /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, + else "IV" now, independent of how it came in. + if a, b represents positive, A, B negative, a maps to -A etc + a + b => (a + b) + A + b => -(a - b) + a + B => (a - b) + A + B => -(a + b) + all UV maths. negate result if A negative. + add if signs same, subtract if signs differ. */ + + if (auvok ^ buvok) { + /* Signs differ. */ + if (auv >= buv) { + result = auv - buv; + /* Must get smaller */ + if (result <= auv) + result_good = 1; + } else { + result = buv - auv; + if (result <= buv) { + /* result really should be -(auv-buv). as its negation + of true value, need to swap our result flag */ + auvok = !auvok; + result_good = 1; + } + } + } else { + /* Signs same */ + result = auv + buv; + if (result >= auv) + result_good = 1; + } + if (result_good) { + SP--; + if (auvok) + SETu( result ); + else { + /* Negate result */ + if (result <= (UV)IV_MIN) SETi(result == (UV)IV_MIN ? IV_MIN : -(IV)result); - else { - /* result valid, but out of range for IV. */ - SETn( -(NV)result ); - } - } - RETURN; - } /* Overflow, drop through to NVs. */ - } + else { + /* result valid, but out of range for IV. */ + SETn( -(NV)result ); + } + } + RETURN; + } /* Overflow, drop through to NVs. */ + } } #else @@ -1607,15 +1607,15 @@ PP(pp_add) #endif { - NV value = SvNV_nomg(svr); - (void)POPs; - if (!useleft) { - /* left operand is undef, treat as zero. + 0.0 is identity. */ - SETn(value); - RETURN; - } - SETn( value + SvNV_nomg(svl) ); - RETURN; + NV value = SvNV_nomg(svr); + (void)POPs; + if (!useleft) { + /* left operand is undef, treat as zero. + 0.0 is identity. */ + SETn(value); + RETURN; + } + SETn( value + SvNV_nomg(svl) ); + RETURN; } } @@ -1626,7 +1626,7 @@ PP(pp_aelemfast) { dSP; AV * const av = PL_op->op_type == OP_AELEMFAST_LEX - ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv); + ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv); const U32 lval = PL_op->op_flags & OPf_MOD; const I8 key = (I8)PL_op->op_private; SV** svp; @@ -1653,7 +1653,7 @@ PP(pp_aelemfast) DIE(aTHX_ PL_no_aelem, (int)key); if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */ - mg_get(sv); + mg_get(sv); PUSHs(sv); RETURN; } @@ -1678,83 +1678,83 @@ PP(pp_print) PerlIO *fp; MAGIC *mg; GV * const gv - = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; + = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; IO *io = GvIO(gv); if (io - && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) + && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { had_magic: - if (MARK == ORIGMARK) { - /* If using default handle then we need to make space to - * pass object as 1st arg, so move other args up ... - */ - MEXTEND(SP, 1); - ++MARK; - Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); - ++SP; - } - return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io), - mg, - (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK - | (PL_op->op_type == OP_SAY - ? TIED_METHOD_SAY : 0)), sp - mark); + if (MARK == ORIGMARK) { + /* If using default handle then we need to make space to + * pass object as 1st arg, so move other args up ... + */ + MEXTEND(SP, 1); + ++MARK; + Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); + ++SP; + } + return Perl_tied_method(aTHX_ SV_CONST(PRINT), mark - 1, MUTABLE_SV(io), + mg, + (G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK + | (PL_op->op_type == OP_SAY + ? TIED_METHOD_SAY : 0)), sp - mark); } if (!io) { if ( gv && GvEGVx(gv) && (io = GvIO(GvEGV(gv))) - && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) + && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) goto had_magic; - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); - goto just_say_no; + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + goto just_say_no; } else if (!(fp = IoOFP(io))) { - if (IoIFP(io)) - report_wrongway_fh(gv, '<'); - else - report_evil_fh(gv); - SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); - goto just_say_no; + if (IoIFP(io)) + report_wrongway_fh(gv, '<'); + else + report_evil_fh(gv); + SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); + goto just_say_no; } else { - SV * const ofs = GvSV(PL_ofsgv); /* $, */ - MARK++; - if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) { - while (MARK <= SP) { - if (!do_print(*MARK, fp)) - break; - MARK++; - if (MARK <= SP) { - /* don't use 'ofs' here - it may be invalidated by magic callbacks */ - if (!do_print(GvSV(PL_ofsgv), fp)) { - MARK--; - break; - } - } - } - } - else { - while (MARK <= SP) { - if (!do_print(*MARK, fp)) - break; - MARK++; - } - } - if (MARK <= SP) - goto just_say_no; - else { - if (PL_op->op_type == OP_SAY) { - if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp)) - goto just_say_no; - } + SV * const ofs = GvSV(PL_ofsgv); /* $, */ + MARK++; + if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) { + while (MARK <= SP) { + if (!do_print(*MARK, fp)) + break; + MARK++; + if (MARK <= SP) { + /* don't use 'ofs' here - it may be invalidated by magic callbacks */ + if (!do_print(GvSV(PL_ofsgv), fp)) { + MARK--; + break; + } + } + } + } + else { + while (MARK <= SP) { + if (!do_print(*MARK, fp)) + break; + MARK++; + } + } + if (MARK <= SP) + goto just_say_no; + else { + if (PL_op->op_type == OP_SAY) { + if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp)) + goto just_say_no; + } else if (PL_ors_sv && SvOK(PL_ors_sv)) - if (!do_print(PL_ors_sv, fp)) /* $\ */ - goto just_say_no; + if (!do_print(PL_ors_sv, fp)) /* $\ */ + goto just_say_no; - if (IoFLAGS(io) & IOf_FLUSH) - if (PerlIO_flush(fp) == EOF) - goto just_say_no; - } + if (IoFLAGS(io) & IOf_FLUSH) + if (PerlIO_flush(fp) == EOF) + goto just_say_no; + } } SP = ORIGMARK; XPUSHs(&PL_sv_yes); @@ -1859,18 +1859,18 @@ PP(pp_padav) U8 gimme; assert(SvTYPE(TARG) == SVt_PVAV); if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) - if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) - SAVECLEARSV(PAD_SVl(PL_op->op_targ)); + if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) + SAVECLEARSV(PAD_SVl(PL_op->op_targ)); EXTEND(SP, 1); if (PL_op->op_flags & OPf_REF) { - PUSHs(TARG); - RETURN; + PUSHs(TARG); + RETURN; } else if (PL_op->op_private & OPpMAYBE_LVSUB) { const I32 flags = is_lvalue_sub(); if (flags && !(flags & OPpENTERSUB_INARGS)) { - if (GIMME_V == G_SCALAR) + if (GIMME_V == G_SCALAR) /* diag_listed_as: Can't return %s to lvalue scalar context */ Perl_croak(aTHX_ "Can't return array to lvalue scalar context"); PUSHs(TARG); @@ -1883,7 +1883,7 @@ PP(pp_padav) return S_pushav(aTHX_ (AV*)TARG); if (gimme == G_SCALAR) { - const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; + const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1; if (!maxarg) PUSHs(&PL_sv_zero); else if (PL_op->op_private & OPpTRUEBOOL) @@ -1902,14 +1902,14 @@ PP(pp_padhv) assert(SvTYPE(TARG) == SVt_PVHV); if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO )) - if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) - SAVECLEARSV(PAD_SVl(PL_op->op_targ)); + if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) )) + SAVECLEARSV(PAD_SVl(PL_op->op_targ)); EXTEND(SP, 1); if (PL_op->op_flags & OPf_REF) { PUSHs(TARG); - RETURN; + RETURN; } else if (PL_op->op_private & OPpMAYBE_LVSUB) { const I32 flags = is_lvalue_sub(); @@ -1940,70 +1940,70 @@ PP(pp_rv2av) static const char an_array[] = "an ARRAY"; static const char a_hash[] = "a HASH"; const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV - || PL_op->op_type == OP_LVAVREF; + || PL_op->op_type == OP_LVAVREF; const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV; SvGETMAGIC(sv); if (SvROK(sv)) { - if (UNLIKELY(SvAMAGIC(sv))) { - sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg); - } - sv = SvRV(sv); - if (UNLIKELY(SvTYPE(sv) != type)) - /* diag_listed_as: Not an ARRAY reference */ - DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash); - else if (UNLIKELY(PL_op->op_flags & OPf_MOD - && PL_op->op_private & OPpLVAL_INTRO)) - Perl_croak(aTHX_ "%s", PL_no_localize_ref); + if (UNLIKELY(SvAMAGIC(sv))) { + sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg); + } + sv = SvRV(sv); + if (UNLIKELY(SvTYPE(sv) != type)) + /* diag_listed_as: Not an ARRAY reference */ + DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash); + else if (UNLIKELY(PL_op->op_flags & OPf_MOD + && PL_op->op_private & OPpLVAL_INTRO)) + Perl_croak(aTHX_ "%s", PL_no_localize_ref); } else if (UNLIKELY(SvTYPE(sv) != type)) { - GV *gv; - - if (!isGV_with_GP(sv)) { - gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash, - type, &sp); - if (!gv) - RETURN; - } - else { - gv = MUTABLE_GV(sv); - } - sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv)); - if (PL_op->op_private & OPpLVAL_INTRO) - sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv)); + GV *gv; + + if (!isGV_with_GP(sv)) { + gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash, + type, &sp); + if (!gv) + RETURN; + } + else { + gv = MUTABLE_GV(sv); + } + sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv)); + if (PL_op->op_private & OPpLVAL_INTRO) + sv = is_pp_rv2av ? MUTABLE_SV(save_ary(gv)) : MUTABLE_SV(save_hash(gv)); } if (PL_op->op_flags & OPf_REF) { - SETs(sv); - RETURN; + SETs(sv); + RETURN; } else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) { - const I32 flags = is_lvalue_sub(); - if (flags && !(flags & OPpENTERSUB_INARGS)) { - if (gimme != G_ARRAY) - goto croak_cant_return; - SETs(sv); - RETURN; - } + const I32 flags = is_lvalue_sub(); + if (flags && !(flags & OPpENTERSUB_INARGS)) { + if (gimme != G_ARRAY) + goto croak_cant_return; + SETs(sv); + RETURN; + } } if (is_pp_rv2av) { - AV *const av = MUTABLE_AV(sv); + AV *const av = MUTABLE_AV(sv); - if (gimme == G_ARRAY) { + if (gimme == G_ARRAY) { SP--; PUTBACK; return S_pushav(aTHX_ av); - } + } - if (gimme == G_SCALAR) { - const SSize_t maxarg = AvFILL(av) + 1; + if (gimme == G_SCALAR) { + const SSize_t maxarg = AvFILL(av) + 1; if (PL_op->op_private & OPpTRUEBOOL) SETs(maxarg ? &PL_sv_yes : &PL_sv_zero); else { dTARGET; SETi(maxarg); } - } + } } else { SP--; PUTBACK; @@ -2015,7 +2015,7 @@ PP(pp_rv2av) croak_cant_return: Perl_croak(aTHX_ "Can't return %s to lvalue scalar context", - is_pp_rv2av ? "array" : "hash"); + is_pp_rv2av ? "array" : "hash"); RETURN; } @@ -2026,18 +2026,18 @@ S_do_oddball(pTHX_ SV **oddkey, SV **firstkey) if (*oddkey) { if (ckWARN(WARN_MISC)) { - const char *err; - if (oddkey == firstkey && - SvROK(*oddkey) && - (SvTYPE(SvRV(*oddkey)) == SVt_PVAV || - SvTYPE(SvRV(*oddkey)) == SVt_PVHV)) - { - err = "Reference found where even-sized list expected"; - } - else - err = "Odd number of elements in hash assignment"; - Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err); - } + const char *err; + if (oddkey == firstkey && + SvROK(*oddkey) && + (SvTYPE(SvRV(*oddkey)) == SVt_PVAV || + SvTYPE(SvRV(*oddkey)) == SVt_PVHV)) + { + err = "Reference found where even-sized list expected"; + } + else + err = "Odd number of elements in hash assignment"; + Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err); + } } } @@ -2282,20 +2282,20 @@ PP(pp_aassign) /* first lelem loop while there are still relems */ while (LIKELY(lelem <= lastlelem)) { - bool alias = FALSE; - SV *lsv = *lelem++; + bool alias = FALSE; + SV *lsv = *lelem++; TAINT_NOT; /* Each item stands on its own, taintwise. */ assert(relem <= lastrelem); - if (UNLIKELY(!lsv)) { - alias = TRUE; - lsv = *lelem++; - ASSUME(SvTYPE(lsv) == SVt_PVAV); - } - - switch (SvTYPE(lsv)) { - case SVt_PVAV: { + if (UNLIKELY(!lsv)) { + alias = TRUE; + lsv = *lelem++; + ASSUME(SvTYPE(lsv) == SVt_PVAV); + } + + switch (SvTYPE(lsv)) { + case SVt_PVAV: { SV **svp; SSize_t i; SSize_t tmps_base; @@ -2457,16 +2457,16 @@ PP(pp_aassign) PL_tmps_ix -= (nelems + 1); } - if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA)) + if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA)) /* its assumed @ISA set magic can't die and leak ary */ - SvSETMAGIC(MUTABLE_SV(ary)); + SvSETMAGIC(MUTABLE_SV(ary)); SvREFCNT_dec_NN(ary); relem = lastrelem + 1; - goto no_relems; + goto no_relems; } - case SVt_PVHV: { /* normal hash */ + case SVt_PVHV: { /* normal hash */ SV **svp; bool dirty_tmps; @@ -2668,11 +2668,11 @@ PP(pp_aassign) SvREFCNT_dec_NN(hash); relem = lastrelem + 1; - goto no_relems; - } + goto no_relems; + } - default: - if (!SvIMMORTAL(lsv)) { + default: + if (!SvIMMORTAL(lsv)) { SV *ref; if (UNLIKELY( @@ -2707,7 +2707,7 @@ PP(pp_aassign) } if (++relem > lastrelem) goto no_relems; - break; + break; } /* switch */ } /* while */ @@ -2716,17 +2716,17 @@ PP(pp_aassign) /* simplified lelem loop for when there are no relems left */ while (LIKELY(lelem <= lastlelem)) { - SV *lsv = *lelem++; + SV *lsv = *lelem++; TAINT_NOT; /* Each item stands on its own, taintwise. */ - if (UNLIKELY(!lsv)) { - lsv = *lelem++; - ASSUME(SvTYPE(lsv) == SVt_PVAV); - } + if (UNLIKELY(!lsv)) { + lsv = *lelem++; + ASSUME(SvTYPE(lsv) == SVt_PVAV); + } - switch (SvTYPE(lsv)) { - case SVt_PVAV: + switch (SvTYPE(lsv)) { + case SVt_PVAV: if (SvRMAGICAL(lsv) || AvFILLp((SV*)lsv) >= 0) { av_clear((AV*)lsv); if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA)) @@ -2734,34 +2734,34 @@ PP(pp_aassign) } break; - case SVt_PVHV: + case SVt_PVHV: if (SvRMAGICAL(lsv) || HvUSEDKEYS((HV*)lsv)) hv_clear((HV*)lsv); break; - default: - if (!SvIMMORTAL(lsv)) { + default: + if (!SvIMMORTAL(lsv)) { sv_set_undef(lsv); SvSETMAGIC(lsv); } *relem++ = lsv; - break; + break; } /* switch */ } /* while */ TAINT_NOT; /* result of list assign isn't tainted */ if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) { - /* Will be used to set PL_tainting below */ - Uid_t tmp_uid = PerlProc_getuid(); - Uid_t tmp_euid = PerlProc_geteuid(); - Gid_t tmp_gid = PerlProc_getgid(); - Gid_t tmp_egid = PerlProc_getegid(); + /* Will be used to set PL_tainting below */ + Uid_t tmp_uid = PerlProc_getuid(); + Uid_t tmp_euid = PerlProc_geteuid(); + Gid_t tmp_gid = PerlProc_getgid(); + Gid_t tmp_egid = PerlProc_getegid(); /* XXX $> et al currently silently ignore failures */ - if (PL_delaymagic & DM_UID) { + if (PL_delaymagic & DM_UID) { #ifdef HAS_SETRESUID - PERL_UNUSED_RESULT( + PERL_UNUSED_RESULT( setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1, (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1, (Uid_t)-1)); @@ -2771,62 +2771,62 @@ PP(pp_aassign) (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1)); #else # ifdef HAS_SETRUID - if ((PL_delaymagic & DM_UID) == DM_RUID) { - PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid)); - PL_delaymagic &= ~DM_RUID; - } + if ((PL_delaymagic & DM_UID) == DM_RUID) { + PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid)); + PL_delaymagic &= ~DM_RUID; + } # endif /* HAS_SETRUID */ # ifdef HAS_SETEUID - if ((PL_delaymagic & DM_UID) == DM_EUID) { - PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid)); - PL_delaymagic &= ~DM_EUID; - } + if ((PL_delaymagic & DM_UID) == DM_EUID) { + PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid)); + PL_delaymagic &= ~DM_EUID; + } # endif /* HAS_SETEUID */ - if (PL_delaymagic & DM_UID) { - if (PL_delaymagic_uid != PL_delaymagic_euid) - DIE(aTHX_ "No setreuid available"); - PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid)); - } + if (PL_delaymagic & DM_UID) { + if (PL_delaymagic_uid != PL_delaymagic_euid) + DIE(aTHX_ "No setreuid available"); + PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid)); + } #endif /* HAS_SETRESUID */ - tmp_uid = PerlProc_getuid(); - tmp_euid = PerlProc_geteuid(); - } + tmp_uid = PerlProc_getuid(); + tmp_euid = PerlProc_geteuid(); + } /* XXX $> et al currently silently ignore failures */ - if (PL_delaymagic & DM_GID) { + if (PL_delaymagic & DM_GID) { #ifdef HAS_SETRESGID - PERL_UNUSED_RESULT( + PERL_UNUSED_RESULT( setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1, (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1, (Gid_t)-1)); #elif defined(HAS_SETREGID) - PERL_UNUSED_RESULT( + PERL_UNUSED_RESULT( setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1, (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1)); #else # ifdef HAS_SETRGID - if ((PL_delaymagic & DM_GID) == DM_RGID) { - PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid)); - PL_delaymagic &= ~DM_RGID; - } + if ((PL_delaymagic & DM_GID) == DM_RGID) { + PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid)); + PL_delaymagic &= ~DM_RGID; + } # endif /* HAS_SETRGID */ # ifdef HAS_SETEGID - if ((PL_delaymagic & DM_GID) == DM_EGID) { - PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid)); - PL_delaymagic &= ~DM_EGID; - } + if ((PL_delaymagic & DM_GID) == DM_EGID) { + PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid)); + PL_delaymagic &= ~DM_EGID; + } # endif /* HAS_SETEGID */ - if (PL_delaymagic & DM_GID) { - if (PL_delaymagic_gid != PL_delaymagic_egid) - DIE(aTHX_ "No setregid available"); - PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid)); - } + if (PL_delaymagic & DM_GID) { + if (PL_delaymagic_gid != PL_delaymagic_egid) + DIE(aTHX_ "No setregid available"); + PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid)); + } #endif /* HAS_SETRESGID */ - tmp_gid = PerlProc_getgid(); - tmp_egid = PerlProc_getegid(); - } - TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) ); + tmp_gid = PerlProc_getgid(); + tmp_egid = PerlProc_getegid(); + } + TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) ); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(tmp_uid); PERL_UNUSED_VAR(tmp_euid); @@ -2837,9 +2837,9 @@ PP(pp_aassign) PL_delaymagic = old_delaymagic; if (gimme == G_VOID) - SP = firstrelem - 1; + SP = firstrelem - 1; else if (gimme == G_SCALAR) { - SP = firstrelem; + SP = firstrelem; EXTEND(SP,1); if (PL_op->op_private & OPpASSIGN_TRUEBOOL) SETs((firstlelem - firstrelem) ? &PL_sv_yes : &PL_sv_zero); @@ -2877,14 +2877,14 @@ PP(pp_qr) cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv); if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) { - *cvp = cv_clone(cv); - SvREFCNT_dec_NN(cv); + *cvp = cv_clone(cv); + SvREFCNT_dec_NN(cv); } if (pkg) { - HV *const stash = gv_stashsv(pkg, GV_ADD); - SvREFCNT_dec_NN(pkg); - (void)sv_bless(rv, stash); + HV *const stash = gv_stashsv(pkg, GV_ADD); + SvREFCNT_dec_NN(pkg); + (void)sv_bless(rv, stash); } if (UNLIKELY(RXp_ISTAINTED(prog))) { @@ -2957,27 +2957,27 @@ PP(pp_match) MAGIC *mg = NULL; if (PL_op->op_flags & OPf_STACKED) - TARG = POPs; + TARG = POPs; else { if (ARGTARG) GETTARGET; else { TARG = DEFSV; } - EXTEND(SP,1); + EXTEND(SP,1); } PUTBACK; /* EVAL blocks need stack_sp. */ /* Skip get-magic if this is a qr// clone, because regcomp has already done it. */ truebase = prog->mother_re - ? SvPV_nomg_const(TARG, len) - : SvPV_const(TARG, len); + ? SvPV_nomg_const(TARG, len) + : SvPV_const(TARG, len); if (!truebase) - DIE(aTHX_ "panic: pp_match"); + DIE(aTHX_ "panic: pp_match"); strend = truebase + len; rxtainted = (RXp_ISTAINTED(prog) || - (TAINT_get && (pm->op_pmflags & PMf_RETAINT))); + (TAINT_get && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; /* We need to know this in case we fail out early - pos() must be reset */ @@ -2994,7 +2994,7 @@ PP(pp_match) if (UNLIKELY(should_we_output_Debug_r(prog))) { PerlIO_printf(Perl_debug_log, "?? already matched once"); } - goto nope; + goto nope; } /* handle the empty pattern */ @@ -3020,7 +3020,7 @@ PP(pp_match) "String shorter than min possible regex match (%zd < %zd)\n", len, RXp_MINLEN(prog)); } - goto nope; + goto nope; } /* get pos() if //g */ @@ -3042,7 +3042,7 @@ PP(pp_match) ) #endif { - r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE); + r_flags |= (REXEC_COPY_STR|REXEC_COPY_SKIP_PRE); /* in @a =~ /(.)/g, we iterate multiple times, but copy the buffer * only on the first iteration. Therefore we need to copy $' as well * as $&, to make the rest of the string available for captures in @@ -3060,22 +3060,22 @@ PP(pp_match) play_it_again: if (global) - s = truebase + curpos; + s = truebase + curpos; if (!CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, - had_zerolen, TARG, NULL, r_flags)) - goto nope; + had_zerolen, TARG, NULL, r_flags)) + goto nope; PL_curpm = pm; if (dynpm->op_pmflags & PMf_ONCE) #ifdef USE_ITHREADS - SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); + SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]); #else - dynpm->op_pmflags |= PMf_USED; + dynpm->op_pmflags |= PMf_USED; #endif if (rxtainted) - RXp_MATCH_TAINTED_on(prog); + RXp_MATCH_TAINTED_on(prog); TAINT_IF(RXp_MATCH_TAINTED(prog)); /* update pos */ @@ -3091,49 +3091,49 @@ PP(pp_match) } if ((!RXp_NPARENS(prog) && !global) || gimme != G_ARRAY) { - LEAVE_SCOPE(oldsave); - RETPUSHYES; + LEAVE_SCOPE(oldsave); + RETPUSHYES; } /* push captures on stack */ { - const I32 nparens = RXp_NPARENS(prog); - I32 i = (global && !nparens) ? 1 : 0; - - SPAGAIN; /* EVAL blocks could move the stack. */ - EXTEND(SP, nparens + i); - EXTEND_MORTAL(nparens + i); - for (i = !i; i <= nparens; i++) { - PUSHs(sv_newmortal()); - if (LIKELY((RXp_OFFS(prog)[i].start != -1) + const I32 nparens = RXp_NPARENS(prog); + I32 i = (global && !nparens) ? 1 : 0; + + SPAGAIN; /* EVAL blocks could move the stack. */ + EXTEND(SP, nparens + i); + EXTEND_MORTAL(nparens + i); + for (i = !i; i <= nparens; i++) { + PUSHs(sv_newmortal()); + if (LIKELY((RXp_OFFS(prog)[i].start != -1) && RXp_OFFS(prog)[i].end != -1 )) { - const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start; - const char * const s = RXp_OFFS(prog)[i].start + truebase; - if (UNLIKELY( RXp_OFFS(prog)[i].end < 0 + const I32 len = RXp_OFFS(prog)[i].end - RXp_OFFS(prog)[i].start; + const char * const s = RXp_OFFS(prog)[i].start + truebase; + if (UNLIKELY( RXp_OFFS(prog)[i].end < 0 || RXp_OFFS(prog)[i].start < 0 || len < 0 || len > strend - s) ) - DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, " - "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf, - (long) i, (long) RXp_OFFS(prog)[i].start, - (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len); - sv_setpvn(*SP, s, len); - if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len)) - SvUTF8_on(*SP); - } - } - if (global) { + DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, " + "start=%ld, end=%ld, s=%p, strend=%p, len=%" UVuf, + (long) i, (long) RXp_OFFS(prog)[i].start, + (long)RXp_OFFS(prog)[i].end, s, strend, (UV) len); + sv_setpvn(*SP, s, len); + if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len)) + SvUTF8_on(*SP); + } + } + if (global) { curpos = (UV)RXp_OFFS(prog)[0].end; - had_zerolen = RXp_ZERO_LEN(prog); - PUTBACK; /* EVAL blocks may use stack */ - r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; - goto play_it_again; - } - LEAVE_SCOPE(oldsave); - RETURN; + had_zerolen = RXp_ZERO_LEN(prog); + PUTBACK; /* EVAL blocks may use stack */ + r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST; + goto play_it_again; + } + LEAVE_SCOPE(oldsave); + RETURN; } NOT_REACHED; /* NOTREACHED */ @@ -3146,7 +3146,7 @@ PP(pp_match) } LEAVE_SCOPE(oldsave); if (gimme == G_ARRAY) - RETURN; + RETURN; RETPUSHNO; } @@ -3163,104 +3163,104 @@ Perl_do_readline(pTHX) const U8 gimme = GIMME_V; if (io) { - const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { - Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0); - if (gimme == G_SCALAR) { - SPAGAIN; - SvSetSV_nosteal(TARG, TOPs); - SETTARG; - } - return NORMAL; - } + const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { + Perl_tied_method(aTHX_ SV_CONST(READLINE), SP, MUTABLE_SV(io), mg, gimme, 0); + if (gimme == G_SCALAR) { + SPAGAIN; + SvSetSV_nosteal(TARG, TOPs); + SETTARG; + } + return NORMAL; + } } fp = NULL; if (io) { - fp = IoIFP(io); - if (!fp) { - if (IoFLAGS(io) & IOf_ARGV) { - if (IoFLAGS(io) & IOf_START) { - IoLINES(io) = 0; - if (av_count(GvAVn(PL_last_in_gv)) == 0) { - IoFLAGS(io) &= ~IOf_START; - do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0); - SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */ - sv_setpvs(GvSVn(PL_last_in_gv), "-"); - SvSETMAGIC(GvSV(PL_last_in_gv)); - fp = IoIFP(io); - goto have_fp; - } - } - fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); - if (!fp) { /* Note: fp != IoIFP(io) */ - (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ - } - } - else if (type == OP_GLOB) - fp = Perl_start_glob(aTHX_ POPs, io); - } - else if (type == OP_GLOB) - SP--; - else if (IoTYPE(io) == IoTYPE_WRONLY) { - report_wrongway_fh(PL_last_in_gv, '>'); - } + fp = IoIFP(io); + if (!fp) { + if (IoFLAGS(io) & IOf_ARGV) { + if (IoFLAGS(io) & IOf_START) { + IoLINES(io) = 0; + if (av_count(GvAVn(PL_last_in_gv)) == 0) { + IoFLAGS(io) &= ~IOf_START; + do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0); + SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */ + sv_setpvs(GvSVn(PL_last_in_gv), "-"); + SvSETMAGIC(GvSV(PL_last_in_gv)); + fp = IoIFP(io); + goto have_fp; + } + } + fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); + if (!fp) { /* Note: fp != IoIFP(io) */ + (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ + } + } + else if (type == OP_GLOB) + fp = Perl_start_glob(aTHX_ POPs, io); + } + else if (type == OP_GLOB) + SP--; + else if (IoTYPE(io) == IoTYPE_WRONLY) { + report_wrongway_fh(PL_last_in_gv, '>'); + } } if (!fp) { - if ((!io || !(IoFLAGS(io) & IOf_START)) - && ckWARN(WARN_CLOSED) + if ((!io || !(IoFLAGS(io) & IOf_START)) + && ckWARN(WARN_CLOSED) && type != OP_GLOB) - { - report_evil_fh(PL_last_in_gv); - } - if (gimme == G_SCALAR) { - /* undef TARG, and push that undefined value */ - if (type != OP_RCATLINE) { - sv_set_undef(TARG); - } - PUSHTARG; - } - RETURN; + { + report_evil_fh(PL_last_in_gv); + } + if (gimme == G_SCALAR) { + /* undef TARG, and push that undefined value */ + if (type != OP_RCATLINE) { + sv_set_undef(TARG); + } + PUSHTARG; + } + RETURN; } have_fp: if (gimme == G_SCALAR) { - sv = TARG; - if (type == OP_RCATLINE && SvGMAGICAL(sv)) - mg_get(sv); - if (SvROK(sv)) { - if (type == OP_RCATLINE) - SvPV_force_nomg_nolen(sv); - else - sv_unref(sv); - } - else if (isGV_with_GP(sv)) { - SvPV_force_nomg_nolen(sv); - } - SvUPGRADE(sv, SVt_PV); - tmplen = SvLEN(sv); /* remember if already alloced */ - if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) { + sv = TARG; + if (type == OP_RCATLINE && SvGMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv)) { + if (type == OP_RCATLINE) + SvPV_force_nomg_nolen(sv); + else + sv_unref(sv); + } + else if (isGV_with_GP(sv)) { + SvPV_force_nomg_nolen(sv); + } + SvUPGRADE(sv, SVt_PV); + tmplen = SvLEN(sv); /* remember if already alloced */ + if (!tmplen && !SvREADONLY(sv) && !SvIsCOW(sv)) { /* try short-buffering it. Please update t/op/readline.t - * if you change the growth length. - */ - Sv_Grow(sv, 80); - } - offset = 0; - if (type == OP_RCATLINE && SvOK(sv)) { - if (!SvPOK(sv)) { - SvPV_force_nomg_nolen(sv); - } - offset = SvCUR(sv); - } + * if you change the growth length. + */ + Sv_Grow(sv, 80); + } + offset = 0; + if (type == OP_RCATLINE && SvOK(sv)) { + if (!SvPOK(sv)) { + SvPV_force_nomg_nolen(sv); + } + offset = SvCUR(sv); + } } else { - sv = sv_2mortal(newSV(80)); - offset = 0; + sv = sv_2mortal(newSV(80)); + offset = 0; } /* This should not be marked tainted if the fp is marked clean */ #define MAYBE_TAINT_LINE(io, sv) \ if (!(IoFLAGS(io) & IOf_UNTAINT)) { \ - TAINT; \ - SvTAINTED_on(sv); \ + TAINT; \ + SvTAINTED_on(sv); \ } /* delay EOF state for a snarfed empty file */ @@ -3269,93 +3269,93 @@ Perl_do_readline(pTHX) || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs)) for (;;) { - PUTBACK; - if (!sv_gets(sv, fp, offset) - && (type == OP_GLOB - || SNARF_EOF(gimme, PL_rs, io, sv) - || PerlIO_error(fp))) - { - PerlIO_clearerr(fp); - if (IoFLAGS(io) & IOf_ARGV) { - fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); - if (fp) - continue; - (void)do_close(PL_last_in_gv, FALSE); - } - else if (type == OP_GLOB) { - if (!do_close(PL_last_in_gv, FALSE)) { - Perl_ck_warner(aTHX_ packWARN(WARN_GLOB), - "glob failed (child exited with status %d%s)", - (int)(STATUS_CURRENT >> 8), - (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); - } - } - if (gimme == G_SCALAR) { - if (type != OP_RCATLINE) { - SV_CHECK_THINKFIRST_COW_DROP(TARG); - SvOK_off(TARG); - } - SPAGAIN; - PUSHTARG; - } - MAYBE_TAINT_LINE(io, sv); - RETURN; - } - MAYBE_TAINT_LINE(io, sv); - IoLINES(io)++; - IoFLAGS(io) |= IOf_NOLINE; - SvSETMAGIC(sv); - SPAGAIN; - XPUSHs(sv); - if (type == OP_GLOB) { - const char *t1; - Stat_t statbuf; - - if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { - char * const tmps = SvEND(sv) - 1; - if (*tmps == *SvPVX_const(PL_rs)) { - *tmps = '\0'; - SvCUR_set(sv, SvCUR(sv) - 1); - } - } - for (t1 = SvPVX_const(sv); *t1; t1++) + PUTBACK; + if (!sv_gets(sv, fp, offset) + && (type == OP_GLOB + || SNARF_EOF(gimme, PL_rs, io, sv) + || PerlIO_error(fp))) + { + PerlIO_clearerr(fp); + if (IoFLAGS(io) & IOf_ARGV) { + fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); + if (fp) + continue; + (void)do_close(PL_last_in_gv, FALSE); + } + else if (type == OP_GLOB) { + if (!do_close(PL_last_in_gv, FALSE)) { + Perl_ck_warner(aTHX_ packWARN(WARN_GLOB), + "glob failed (child exited with status %d%s)", + (int)(STATUS_CURRENT >> 8), + (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); + } + } + if (gimme == G_SCALAR) { + if (type != OP_RCATLINE) { + SV_CHECK_THINKFIRST_COW_DROP(TARG); + SvOK_off(TARG); + } + SPAGAIN; + PUSHTARG; + } + MAYBE_TAINT_LINE(io, sv); + RETURN; + } + MAYBE_TAINT_LINE(io, sv); + IoLINES(io)++; + IoFLAGS(io) |= IOf_NOLINE; + SvSETMAGIC(sv); + SPAGAIN; + XPUSHs(sv); + if (type == OP_GLOB) { + const char *t1; + Stat_t statbuf; + + if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) { + char * const tmps = SvEND(sv) - 1; + if (*tmps == *SvPVX_const(PL_rs)) { + *tmps = '\0'; + SvCUR_set(sv, SvCUR(sv) - 1); + } + } + for (t1 = SvPVX_const(sv); *t1; t1++) #ifdef __VMS - if (memCHRs("*%?", *t1)) + if (memCHRs("*%?", *t1)) #else - if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1)) + if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1)) #endif - break; - if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) { - (void)POPs; /* Unmatched wildcard? Chuck it... */ - continue; - } - } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ - if (ckWARN(WARN_UTF8)) { - const U8 * const s = (const U8*)SvPVX_const(sv) + offset; - const STRLEN len = SvCUR(sv) - offset; - const U8 *f; - - if (!is_utf8_string_loc(s, len, &f)) - /* Emulate :encoding(utf8) warning in the same case. */ - Perl_warner(aTHX_ packWARN(WARN_UTF8), - "utf8 \"\\x%02X\" does not map to Unicode", - f < (U8*)SvEND(sv) ? *f : 0); - } - } - if (gimme == G_ARRAY) { - if (SvLEN(sv) - SvCUR(sv) > 20) { - SvPV_shrink_to_cur(sv); - } - sv = sv_2mortal(newSV(80)); - continue; - } - else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { - /* try to reclaim a bit of scalar space (only on 1st alloc) */ - const STRLEN new_len - = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */ - SvPV_renew(sv, new_len); - } - RETURN; + break; + if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) { + (void)POPs; /* Unmatched wildcard? Chuck it... */ + continue; + } + } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */ + if (ckWARN(WARN_UTF8)) { + const U8 * const s = (const U8*)SvPVX_const(sv) + offset; + const STRLEN len = SvCUR(sv) - offset; + const U8 *f; + + if (!is_utf8_string_loc(s, len, &f)) + /* Emulate :encoding(utf8) warning in the same case. */ + Perl_warner(aTHX_ packWARN(WARN_UTF8), + "utf8 \"\\x%02X\" does not map to Unicode", + f < (U8*)SvEND(sv) ? *f : 0); + } + } + if (gimme == G_ARRAY) { + if (SvLEN(sv) - SvCUR(sv) > 20) { + SvPV_shrink_to_cur(sv); + } + sv = sv_2mortal(newSV(80)); + continue; + } + else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { + /* try to reclaim a bit of scalar space (only on 1st alloc) */ + const STRLEN new_len + = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */ + SvPV_renew(sv, new_len); + } + RETURN; } } @@ -3373,52 +3373,52 @@ PP(pp_helem) bool preeminent = TRUE; if (SvTYPE(hv) != SVt_PVHV) - RETPUSHUNDEF; + RETPUSHUNDEF; if (localizing) { - MAGIC *mg; - HV *stash; + MAGIC *mg; + HV *stash; - /* If we can determine whether the element exist, - * Try to preserve the existenceness of a tied hash - * element by using EXISTS and DELETE if possible. - * Fallback to FETCH and STORE otherwise. */ - if (SvCANEXISTDELETE(hv)) - preeminent = hv_exists_ent(hv, keysv, 0); + /* If we can determine whether the element exist, + * Try to preserve the existenceness of a tied hash + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise. */ + if (SvCANEXISTDELETE(hv)) + preeminent = hv_exists_ent(hv, keysv, 0); } he = hv_fetch_ent(hv, keysv, lval && !defer, 0); svp = he ? &HeVAL(he) : NULL; if (lval) { - if (!svp || !*svp || *svp == &PL_sv_undef) { - SV* lv; - SV* key2; - if (!defer) { - DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); - } - lv = sv_newmortal(); - sv_upgrade(lv, SVt_PVLV); - LvTYPE(lv) = 'y'; - sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0); - SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */ - LvTARG(lv) = SvREFCNT_inc_simple_NN(hv); - LvTARGLEN(lv) = 1; - PUSHs(lv); - RETURN; - } - if (localizing) { - if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) - save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); - else if (preeminent) - save_helem_flags(hv, keysv, svp, - (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); - else - SAVEHDELETE(hv, keysv); - } - else if (PL_op->op_private & OPpDEREF) { - PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF)); - RETURN; - } + if (!svp || !*svp || *svp == &PL_sv_undef) { + SV* lv; + SV* key2; + if (!defer) { + DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv)); + } + lv = sv_newmortal(); + sv_upgrade(lv, SVt_PVLV); + LvTYPE(lv) = 'y'; + sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0); + SvREFCNT_dec_NN(key2); /* sv_magic() increments refcount */ + LvTARG(lv) = SvREFCNT_inc_simple_NN(hv); + LvTARGLEN(lv) = 1; + PUSHs(lv); + RETURN; + } + if (localizing) { + if (HvNAME_get(hv) && isGV_or_RVCV(*svp)) + save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL)); + else if (preeminent) + save_helem_flags(hv, keysv, svp, + (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC); + else + SAVEHDELETE(hv, keysv); + } + else if (PL_op->op_private & OPpDEREF) { + PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF)); + RETURN; + } } sv = (svp && *svp ? *svp : &PL_sv_undef); /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this @@ -3434,7 +3434,7 @@ PP(pp_helem) * compromise, do the get magic here. (The MGf_GSKIP flag will stop it * being called too many times). */ if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv)) - mg_get(sv); + mg_get(sv); PUSHs(sv); RETURN; } @@ -3445,14 +3445,14 @@ PP(pp_helem) STATIC GV * S_softref2xv_lite(pTHX_ SV *const sv, const char *const what, - const svtype type) + const svtype type) { if (PL_op->op_private & HINT_STRICT_REFS) { - if (SvOK(sv)) - Perl_die(aTHX_ PL_no_symref_sv, sv, - (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); - else - Perl_die(aTHX_ PL_no_usym, what); + if (SvOK(sv)) + Perl_die(aTHX_ PL_no_symref_sv, sv, + (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); + else + Perl_die(aTHX_ PL_no_usym, what); } if (!SvOK(sv)) Perl_die(aTHX_ PL_no_usym, what); @@ -3938,13 +3938,13 @@ PP(pp_iter) case CXt_LOOP_LAZYIV: /* integer increment */ { IV cur = cx->blk_loop.state_u.lazyiv.cur; - if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end)) - goto retno; + if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end)) + goto retno; oldsv = *itersvp; - /* see NB comment above */ - if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) { - /* safe to reuse old SV */ + /* see NB comment above */ + if (oldsv && LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) { + /* safe to reuse old SV */ if ( (SvFLAGS(oldsv) & (SVTYPEMASK|SVf_THINKFIRST|SVf_IVisUV)) == SVt_IV) @@ -3961,21 +3961,21 @@ PP(pp_iter) } else sv_setiv(oldsv, cur); - } - else - { - /* we need a fresh SV every time so that loop body sees a - * completely new SV for closures/references to work as they - * used to */ - *itersvp = newSViv(cur); - SvREFCNT_dec(oldsv); - } - - if (UNLIKELY(cur == IV_MAX)) { - /* Handle end of range at IV_MAX */ - cx->blk_loop.state_u.lazyiv.end = IV_MIN; - } else - ++cx->blk_loop.state_u.lazyiv.cur; + } + else + { + /* we need a fresh SV every time so that loop body sees a + * completely new SV for closures/references to work as they + * used to */ + *itersvp = newSViv(cur); + SvREFCNT_dec(oldsv); + } + + if (UNLIKELY(cur == IV_MAX)) { + /* Handle end of range at IV_MAX */ + cx->blk_loop.state_u.lazyiv.end = IV_MIN; + } else + ++cx->blk_loop.state_u.lazyiv.cur; break; } @@ -4045,7 +4045,7 @@ PP(pp_iter) break; default: - DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx)); + DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx)); } /* Try to bypass pushing &PL_sv_yes and calling pp_and(); instead @@ -4121,34 +4121,34 @@ There are four destinations of taint and they are affected by the sources according to the rules below: * the return value (not including /r): - tainted by the source string and pattern, but only for the - number-of-iterations case; boolean returns aren't tainted; + tainted by the source string and pattern, but only for the + number-of-iterations case; boolean returns aren't tainted; * the modified string (or modified copy under /r): - tainted by the source string, pattern, and replacement strings; + tainted by the source string, pattern, and replacement strings; * $1 et al: - tainted by the pattern, and under 'use re "taint"', by the source - string too; + tainted by the pattern, and under 'use re "taint"', by the source + string too; * PL_taint - i.e. whether subsequent code (e.g. in a /e block) is tainted: - should always be unset before executing subsequent code. + should always be unset before executing subsequent code. The overall action of pp_subst is: * at the start, set bits in rxtainted indicating the taint status of - the various sources. + the various sources. * After each pattern execution, update the SUBST_TAINT_PAT bit in - rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the - pattern has subsequently become tainted via locale ops. + rxtainted if RXf_TAINTED_SEEN has been set, to indicate that the + pattern has subsequently become tainted via locale ops. * If control is being passed to pp_substcont to execute a /e block, - save rxtainted in the CXt_SUBST block, for future use by - pp_substcont. + save rxtainted in the CXt_SUBST block, for future use by + pp_substcont. * Whenever control is being returned to perl code (either by falling - off the "end" of pp_subst/pp_substcont, or by entering a /e block), - use the flag bits in rxtainted to make all the appropriate types of - destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1 - et al will appear tainted. + off the "end" of pp_subst/pp_substcont, or by entering a /e block), + use the flag bits in rxtainted to make all the appropriate types of + destination taint visible; e.g. set RXf_TAINTED_SEEN so that $1 + et al will appear tainted. pp_match is just a simpler version of the above. @@ -4167,7 +4167,7 @@ PP(pp_subst) SSize_t maxiters; bool once; U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits. - See "how taint works" above */ + See "how taint works" above */ char *orig; U8 r_flags; REGEXP *rx = PM_GETRE(pm); @@ -4187,14 +4187,14 @@ PP(pp_subst) PERL_ASYNC_CHECK(); if (PL_op->op_flags & OPf_STACKED) - TARG = POPs; + TARG = POPs; else { if (ARGTARG) GETTARGET; else { TARG = DEFSV; } - EXTEND(SP,1); + EXTEND(SP,1); } SvGETMAGIC(TARG); /* must come before cow check */ @@ -4204,14 +4204,14 @@ PP(pp_subst) #endif if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) { #ifndef PERL_ANY_COW - if (SvIsCOW(TARG)) - sv_force_normal_flags(TARG,0); + if (SvIsCOW(TARG)) + sv_force_normal_flags(TARG,0); #endif - if ((SvREADONLY(TARG) - || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG)) - || SvTYPE(TARG) > SVt_PVLV) - && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) - Perl_croak_no_modify(); + if ((SvREADONLY(TARG) + || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG)) + || SvTYPE(TARG) > SVt_PVLV) + && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))) + Perl_croak_no_modify(); } PUTBACK; @@ -4220,31 +4220,31 @@ PP(pp_subst) * to match, we leave as-is; on successful match however, we *will* * coerce into a string, then repeat the match */ if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG)) - force_on_match = 1; + force_on_match = 1; /* only replace once? */ once = !(rpm->op_pmflags & PMf_GLOBAL); /* See "how taint works" above */ if (TAINTING_get) { - rxtainted = ( - (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0) - | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0) - | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0) - | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT)) + rxtainted = ( + (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0) + | (RXp_ISTAINTED(prog) ? SUBST_TAINT_PAT : 0) + | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0) + | (( (once && !(rpm->op_pmflags & PMf_NONDESTRUCT)) || (PL_op->op_private & OPpTRUEBOOL)) ? SUBST_TAINT_BOOLRET : 0)); - TAINT_NOT; + TAINT_NOT; } force_it: if (!pm || !orig) - DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig); + DIE(aTHX_ "panic: pp_subst, pm=%p, orig=%p", pm, orig); strend = orig + len; slen = DO_UTF8(TARG) ? utf8_length((U8*)orig, (U8*)strend) : len; maxiters = 2 * slen + 10; /* We can match twice at each - position, once with zero-length, - second time with non-zero. */ + position, once with zero-length, + second time with non-zero. */ /* handle the empty pattern */ if (!RX_PRELEN(rx) && PL_curpm && !prog->mother_re) { @@ -4277,40 +4277,40 @@ PP(pp_subst) if (!CALLREGEXEC(rx, orig, strend, orig, 0, TARG, NULL, r_flags)) { - SPAGAIN; - PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no); - LEAVE_SCOPE(oldsave); - RETURN; + SPAGAIN; + PUSHs(rpm->op_pmflags & PMf_NONDESTRUCT ? TARG : &PL_sv_no); + LEAVE_SCOPE(oldsave); + RETURN; } PL_curpm = pm; /* known replacement string? */ if (dstr) { - /* replacement needing upgrading? */ - if (DO_UTF8(TARG) && !doutf8) { - nsv = sv_newmortal(); - SvSetSV(nsv, dstr); - sv_utf8_upgrade(nsv); - c = SvPV_const(nsv, clen); - doutf8 = TRUE; - } - else { - c = SvPV_const(dstr, clen); - doutf8 = DO_UTF8(dstr); - } - - if (UNLIKELY(TAINT_get)) - rxtainted |= SUBST_TAINT_REPL; + /* replacement needing upgrading? */ + if (DO_UTF8(TARG) && !doutf8) { + nsv = sv_newmortal(); + SvSetSV(nsv, dstr); + sv_utf8_upgrade(nsv); + c = SvPV_const(nsv, clen); + doutf8 = TRUE; + } + else { + c = SvPV_const(dstr, clen); + doutf8 = DO_UTF8(dstr); + } + + if (UNLIKELY(TAINT_get)) + rxtainted |= SUBST_TAINT_REPL; } else { - c = NULL; - doutf8 = FALSE; + c = NULL; + doutf8 = FALSE; } /* can do inplace substitution? */ if (c #ifdef PERL_ANY_COW - && !was_cow + && !was_cow #endif && (I32)clen <= RXp_MINLENRET(prog) && ( once @@ -4318,231 +4318,231 @@ PP(pp_subst) || (!SvGMAGICAL(dstr) && !(RXp_EXTFLAGS(prog) & RXf_EVAL_SEEN)) ) && !(RXp_EXTFLAGS(prog) & RXf_NO_INPLACE_SUBST) - && (!doutf8 || SvUTF8(TARG)) - && !(rpm->op_pmflags & PMf_NONDESTRUCT)) + && (!doutf8 || SvUTF8(TARG)) + && !(rpm->op_pmflags & PMf_NONDESTRUCT)) { #ifdef PERL_ANY_COW /* string might have got converted to COW since we set was_cow */ - if (SvIsCOW(TARG)) { - if (!force_on_match) - goto have_a_cow; - assert(SvVOK(TARG)); - } + if (SvIsCOW(TARG)) { + if (!force_on_match) + goto have_a_cow; + assert(SvVOK(TARG)); + } #endif - if (force_on_match) { + if (force_on_match) { /* redo the first match, this time with the orig var * forced into being a string */ - force_on_match = 0; - orig = SvPV_force_nomg(TARG, len); - goto force_it; - } + force_on_match = 0; + orig = SvPV_force_nomg(TARG, len); + goto force_it; + } - if (once) { + if (once) { char *d, *m; - if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */ - rxtainted |= SUBST_TAINT_PAT; - m = orig + RXp_OFFS(prog)[0].start; - d = orig + RXp_OFFS(prog)[0].end; - s = orig; - if (m - s > strend - d) { /* faster to shorten from end */ + if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */ + rxtainted |= SUBST_TAINT_PAT; + m = orig + RXp_OFFS(prog)[0].start; + d = orig + RXp_OFFS(prog)[0].end; + s = orig; + if (m - s > strend - d) { /* faster to shorten from end */ I32 i; - if (clen) { - Copy(c, m, clen, char); - m += clen; - } - i = strend - d; - if (i > 0) { - Move(d, m, i, char); - m += i; - } - *m = '\0'; - SvCUR_set(TARG, m - s); - } - else { /* faster from front */ + if (clen) { + Copy(c, m, clen, char); + m += clen; + } + i = strend - d; + if (i > 0) { + Move(d, m, i, char); + m += i; + } + *m = '\0'; + SvCUR_set(TARG, m - s); + } + else { /* faster from front */ I32 i = m - s; - d -= clen; + d -= clen; if (i > 0) Move(s, d - i, i, char); - sv_chop(TARG, d-i); - if (clen) - Copy(c, d, clen, char); - } - SPAGAIN; - PUSHs(&PL_sv_yes); - } - else { + sv_chop(TARG, d-i); + if (clen) + Copy(c, d, clen, char); + } + SPAGAIN; + PUSHs(&PL_sv_yes); + } + else { char *d, *m; d = s = RXp_OFFS(prog)[0].start + orig; - do { + do { I32 i; - if (UNLIKELY(iters++ > maxiters)) - DIE(aTHX_ "Substitution loop"); + if (UNLIKELY(iters++ > maxiters)) + DIE(aTHX_ "Substitution loop"); /* run time pattern taint, eg locale */ - if (UNLIKELY(RXp_MATCH_TAINTED(prog))) - rxtainted |= SUBST_TAINT_PAT; - m = RXp_OFFS(prog)[0].start + orig; - if ((i = m - s)) { - if (s != d) - Move(s, d, i, char); - d += i; - } - if (clen) { - Copy(c, d, clen, char); - d += clen; - } - s = RXp_OFFS(prog)[0].end + orig; - } while (CALLREGEXEC(rx, s, strend, orig, - s == m, /* don't match same null twice */ - TARG, NULL, + if (UNLIKELY(RXp_MATCH_TAINTED(prog))) + rxtainted |= SUBST_TAINT_PAT; + m = RXp_OFFS(prog)[0].start + orig; + if ((i = m - s)) { + if (s != d) + Move(s, d, i, char); + d += i; + } + if (clen) { + Copy(c, d, clen, char); + d += clen; + } + s = RXp_OFFS(prog)[0].end + orig; + } while (CALLREGEXEC(rx, s, strend, orig, + s == m, /* don't match same null twice */ + TARG, NULL, REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW)); - if (s != d) { + if (s != d) { I32 i = strend - s; - SvCUR_set(TARG, d - SvPVX_const(TARG) + i); - Move(s, d, i+1, char); /* include the NUL */ - } - SPAGAIN; + SvCUR_set(TARG, d - SvPVX_const(TARG) + i); + Move(s, d, i+1, char); /* include the NUL */ + } + SPAGAIN; assert(iters); if (PL_op->op_private & OPpTRUEBOOL) PUSHs(&PL_sv_yes); else mPUSHi(iters); - } + } } else { - bool first; + bool first; char *m; - SV *repl; - if (force_on_match) { + SV *repl; + if (force_on_match) { /* redo the first match, this time with the orig var * forced into being a string */ - force_on_match = 0; - if (rpm->op_pmflags & PMf_NONDESTRUCT) { - /* I feel that it should be possible to avoid this mortal copy - given that the code below copies into a new destination. - However, I suspect it isn't worth the complexity of - unravelling the C<goto force_it> for the small number of - cases where it would be viable to drop into the copy code. */ - TARG = sv_2mortal(newSVsv(TARG)); - } - orig = SvPV_force_nomg(TARG, len); - goto force_it; - } + force_on_match = 0; + if (rpm->op_pmflags & PMf_NONDESTRUCT) { + /* I feel that it should be possible to avoid this mortal copy + given that the code below copies into a new destination. + However, I suspect it isn't worth the complexity of + unravelling the C<goto force_it> for the small number of + cases where it would be viable to drop into the copy code. */ + TARG = sv_2mortal(newSVsv(TARG)); + } + orig = SvPV_force_nomg(TARG, len); + goto force_it; + } #ifdef PERL_ANY_COW have_a_cow: #endif - if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */ - rxtainted |= SUBST_TAINT_PAT; - repl = dstr; + if (RXp_MATCH_TAINTED(prog)) /* run time pattern taint, eg locale */ + rxtainted |= SUBST_TAINT_PAT; + repl = dstr; s = RXp_OFFS(prog)[0].start + orig; - dstr = newSVpvn_flags(orig, s-orig, + dstr = newSVpvn_flags(orig, s-orig, SVs_TEMP | (DO_UTF8(TARG) ? SVf_UTF8 : 0)); - if (!c) { - PERL_CONTEXT *cx; - SPAGAIN; + if (!c) { + PERL_CONTEXT *cx; + SPAGAIN; m = orig; - /* note that a whole bunch of local vars are saved here for - * use by pp_substcont: here's a list of them in case you're - * searching for places in this sub that uses a particular var: - * iters maxiters r_flags oldsave rxtainted orig dstr targ - * s m strend rx once */ - CX_PUSHSUBST(cx); - RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot); - } - first = TRUE; - do { - if (UNLIKELY(iters++ > maxiters)) - DIE(aTHX_ "Substitution loop"); - if (UNLIKELY(RXp_MATCH_TAINTED(prog))) - rxtainted |= SUBST_TAINT_PAT; - if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) { - char *old_s = s; - char *old_orig = orig; + /* note that a whole bunch of local vars are saved here for + * use by pp_substcont: here's a list of them in case you're + * searching for places in this sub that uses a particular var: + * iters maxiters r_flags oldsave rxtainted orig dstr targ + * s m strend rx once */ + CX_PUSHSUBST(cx); + RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot); + } + first = TRUE; + do { + if (UNLIKELY(iters++ > maxiters)) + DIE(aTHX_ "Substitution loop"); + if (UNLIKELY(RXp_MATCH_TAINTED(prog))) + rxtainted |= SUBST_TAINT_PAT; + if (RXp_MATCH_COPIED(prog) && RXp_SUBBEG(prog) != orig) { + char *old_s = s; + char *old_orig = orig; assert(RXp_SUBOFFSET(prog) == 0); - orig = RXp_SUBBEG(prog); - s = orig + (old_s - old_orig); - strend = s + (strend - old_s); - } - m = RXp_OFFS(prog)[0].start + orig; - sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG)); - s = RXp_OFFS(prog)[0].end + orig; - if (first) { - /* replacement already stringified */ - if (clen) - sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8); - first = FALSE; - } - else { - sv_catsv(dstr, repl); - } - if (once) - break; - } while (CALLREGEXEC(rx, s, strend, orig, + orig = RXp_SUBBEG(prog); + s = orig + (old_s - old_orig); + strend = s + (strend - old_s); + } + m = RXp_OFFS(prog)[0].start + orig; + sv_catpvn_nomg_maybeutf8(dstr, s, m - s, DO_UTF8(TARG)); + s = RXp_OFFS(prog)[0].end + orig; + if (first) { + /* replacement already stringified */ + if (clen) + sv_catpvn_nomg_maybeutf8(dstr, c, clen, doutf8); + first = FALSE; + } + else { + sv_catsv(dstr, repl); + } + if (once) + break; + } while (CALLREGEXEC(rx, s, strend, orig, s == m, /* Yields minend of 0 or 1 */ - TARG, NULL, + TARG, NULL, REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW)); assert(strend >= s); - sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG)); - - if (rpm->op_pmflags & PMf_NONDESTRUCT) { - /* From here on down we're using the copy, and leaving the original - untouched. */ - TARG = dstr; - SPAGAIN; - PUSHs(dstr); - } else { + sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG)); + + if (rpm->op_pmflags & PMf_NONDESTRUCT) { + /* From here on down we're using the copy, and leaving the original + untouched. */ + TARG = dstr; + SPAGAIN; + PUSHs(dstr); + } else { #ifdef PERL_ANY_COW - /* The match may make the string COW. If so, brilliant, because - that's just saved us one malloc, copy and free - the regexp has - donated the old buffer, and we malloc an entirely new one, rather - than the regexp malloc()ing a buffer and copying our original, - only for us to throw it away here during the substitution. */ - if (SvIsCOW(TARG)) { - sv_force_normal_flags(TARG, SV_COW_DROP_PV); - } else + /* The match may make the string COW. If so, brilliant, because + that's just saved us one malloc, copy and free - the regexp has + donated the old buffer, and we malloc an entirely new one, rather + than the regexp malloc()ing a buffer and copying our original, + only for us to throw it away here during the substitution. */ + if (SvIsCOW(TARG)) { + sv_force_normal_flags(TARG, SV_COW_DROP_PV); + } else #endif - { - SvPV_free(TARG); - } - SvPV_set(TARG, SvPVX(dstr)); - SvCUR_set(TARG, SvCUR(dstr)); - SvLEN_set(TARG, SvLEN(dstr)); - SvFLAGS(TARG) |= SvUTF8(dstr); - SvPV_set(dstr, NULL); - - SPAGAIN; + { + SvPV_free(TARG); + } + SvPV_set(TARG, SvPVX(dstr)); + SvCUR_set(TARG, SvCUR(dstr)); + SvLEN_set(TARG, SvLEN(dstr)); + SvFLAGS(TARG) |= SvUTF8(dstr); + SvPV_set(dstr, NULL); + + SPAGAIN; if (PL_op->op_private & OPpTRUEBOOL) PUSHs(&PL_sv_yes); else mPUSHi(iters); - } + } } if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) { - (void)SvPOK_only_UTF8(TARG); + (void)SvPOK_only_UTF8(TARG); } /* See "how taint works" above */ if (TAINTING_get) { - if ((rxtainted & SUBST_TAINT_PAT) || - ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == - (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) - ) - (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */ - - if (!(rxtainted & SUBST_TAINT_BOOLRET) - && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) - ) - SvTAINTED_on(TOPs); /* taint return value */ - else - SvTAINTED_off(TOPs); /* may have got tainted earlier */ - - /* needed for mg_set below */ - TAINT_set( - cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) + if ((rxtainted & SUBST_TAINT_PAT) || + ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == + (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RXp_MATCH_TAINTED_on(prog)); /* taint $1 et al */ + + if (!(rxtainted & SUBST_TAINT_BOOLRET) + && (rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) + ) + SvTAINTED_on(TOPs); /* taint return value */ + else + SvTAINTED_off(TOPs); /* may have got tainted earlier */ + + /* needed for mg_set below */ + TAINT_set( + cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) ); - SvTAINT(TARG); + SvTAINT(TARG); } SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */ TAINT_NOT; @@ -4556,48 +4556,48 @@ PP(pp_grepwhile) dPOPss; if (SvTRUE_NN(sv)) - PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; + PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr]; ++*PL_markstack_ptr; FREETMPS; LEAVE_with_name("grep_item"); /* exit inner scope */ /* All done yet? */ if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) { - I32 items; - const U8 gimme = GIMME_V; - - LEAVE_with_name("grep"); /* exit outer scope */ - (void)POPMARK; /* pop src */ - items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; - (void)POPMARK; /* pop dst */ - SP = PL_stack_base + POPMARK; /* pop original mark */ - if (gimme == G_SCALAR) { + I32 items; + const U8 gimme = GIMME_V; + + LEAVE_with_name("grep"); /* exit outer scope */ + (void)POPMARK; /* pop src */ + items = --*PL_markstack_ptr - PL_markstack_ptr[-1]; + (void)POPMARK; /* pop dst */ + SP = PL_stack_base + POPMARK; /* pop original mark */ + if (gimme == G_SCALAR) { if (PL_op->op_private & OPpTRUEBOOL) PUSHs(items ? &PL_sv_yes : &PL_sv_zero); else { - dTARGET; - PUSHi(items); + dTARGET; + PUSHi(items); } - } - else if (gimme == G_ARRAY) - SP += items; - RETURN; + } + else if (gimme == G_ARRAY) + SP += items; + RETURN; } else { - SV *src; + SV *src; - ENTER_with_name("grep_item"); /* enter inner scope */ - SAVEVPTR(PL_curpm); + ENTER_with_name("grep_item"); /* enter inner scope */ + SAVEVPTR(PL_curpm); - src = PL_stack_base[TOPMARK]; - if (SvPADTMP(src)) { - src = PL_stack_base[TOPMARK] = sv_mortalcopy(src); - PL_tmps_floor++; - } - SvTEMP_off(src); - DEFSV_set(src); + src = PL_stack_base[TOPMARK]; + if (SvPADTMP(src)) { + src = PL_stack_base[TOPMARK] = sv_mortalcopy(src); + PL_tmps_floor++; + } + SvTEMP_off(src); + DEFSV_set(src); - RETURNOP(cLOGOP->op_other); + RETURNOP(cLOGOP->op_other); } } @@ -4939,7 +4939,7 @@ PP(pp_leavesub) /* entry zero of a stack is always PL_sv_undef, which * simplifies converting a '()' return into undef in scalar context */ assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef); - return 0; + return 0; } gimme = cx->blk_gimme; @@ -4993,7 +4993,7 @@ PP(pp_entersub) I32 old_savestack_ix; if (UNLIKELY(!sv)) - goto do_die; + goto do_die; /* Locate the CV to call: * - most common case: RV->CV: f(), $ref->(): @@ -5077,32 +5077,32 @@ PP(pp_entersub) assert(cv); assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv)); while (UNLIKELY(!CvROOT(cv))) { - GV* autogv; - SV* sub_name; - - /* anonymous or undef'd function leaves us no recourse */ - if (CvLEXICAL(cv) && CvHASGV(cv)) - DIE(aTHX_ "Undefined subroutine &%" SVf " called", - SVfARG(cv_name(cv, NULL, 0))); - if (CvANON(cv) || !CvHASGV(cv)) { - DIE(aTHX_ "Undefined subroutine called"); - } - - /* autoloaded stub? */ - if (cv != GvCV(gv = CvGV(cv))) { - cv = GvCV(gv); - } - /* should call AUTOLOAD now? */ - else { + GV* autogv; + SV* sub_name; + + /* anonymous or undef'd function leaves us no recourse */ + if (CvLEXICAL(cv) && CvHASGV(cv)) + DIE(aTHX_ "Undefined subroutine &%" SVf " called", + SVfARG(cv_name(cv, NULL, 0))); + if (CvANON(cv) || !CvHASGV(cv)) { + DIE(aTHX_ "Undefined subroutine called"); + } + + /* autoloaded stub? */ + if (cv != GvCV(gv = CvGV(cv))) { + cv = GvCV(gv); + } + /* should call AUTOLOAD now? */ + else { try_autoload: - autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), + autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), (GvNAMEUTF8(gv) ? SVf_UTF8 : 0) |(PL_op->op_flags & OPf_REF ? GV_AUTOLOAD_ISMETHOD : 0)); cv = autogv ? GvCV(autogv) : NULL; - } - if (!cv) { + } + if (!cv) { sub_name = sv_newmortal(); gv_efullname3(sub_name, gv, NULL); DIE(aTHX_ "Undefined subroutine &%" SVf " called", SVfARG(sub_name)); @@ -5111,31 +5111,31 @@ PP(pp_entersub) /* unrolled "CvCLONE(cv) && ! CvCLONED(cv)" */ if (UNLIKELY((CvFLAGS(cv) & (CVf_CLONE|CVf_CLONED)) == CVf_CLONE)) - DIE(aTHX_ "Closure prototype called"); + DIE(aTHX_ "Closure prototype called"); if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv))) { - Perl_get_db_sub(aTHX_ &sv, cv); - if (CvISXSUB(cv)) - PL_curcopdb = PL_curcop; + Perl_get_db_sub(aTHX_ &sv, cv); + if (CvISXSUB(cv)) + PL_curcopdb = PL_curcop; if (CvLVALUE(cv)) { /* check for lsub that handles lvalue subroutines */ - cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV)); + cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV)); /* if lsub not found then fall back to DB::sub */ - if (!cv) cv = GvCV(PL_DBsub); + if (!cv) cv = GvCV(PL_DBsub); } else { cv = GvCV(PL_DBsub); } - if (!cv || (!CvXSUB(cv) && !CvSTART(cv))) - DIE(aTHX_ "No DB::sub routine defined"); + if (!cv || (!CvXSUB(cv) && !CvSTART(cv))) + DIE(aTHX_ "No DB::sub routine defined"); } if (!(CvISXSUB(cv))) { - /* This path taken at least 75% of the time */ - dMARK; - PADLIST *padlist; + /* This path taken at least 75% of the time */ + dMARK; + PADLIST *padlist; I32 depth; bool hasargs; U8 gimme; @@ -5145,7 +5145,7 @@ PP(pp_entersub) * in the caller's tmps frame, so they won't be freed until after * we return from the sub. */ - { + { SV **svp = MARK; while (svp < SP) { SV *sv = *++svp; @@ -5154,26 +5154,26 @@ PP(pp_entersub) if (SvPADTMP(sv)) *svp = sv = sv_mortalcopy(sv); SvTEMP_off(sv); - } + } } gimme = GIMME_V; - cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix); + cx = cx_pushblock(CXt_SUB, gimme, MARK, old_savestack_ix); hasargs = cBOOL(PL_op->op_flags & OPf_STACKED); - cx_pushsub(cx, cv, PL_op->op_next, hasargs); - - padlist = CvPADLIST(cv); - if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) - pad_push(padlist, depth); - PAD_SET_CUR_NOSAVE(padlist, depth); - if (LIKELY(hasargs)) { - AV *const av = MUTABLE_AV(PAD_SVl(0)); + cx_pushsub(cx, cv, PL_op->op_next, hasargs); + + padlist = CvPADLIST(cv); + if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) + pad_push(padlist, depth); + PAD_SET_CUR_NOSAVE(padlist, depth); + if (LIKELY(hasargs)) { + AV *const av = MUTABLE_AV(PAD_SVl(0)); SSize_t items; AV **defavp; - defavp = &GvAV(PL_defgv); - cx->blk_sub.savearray = *defavp; - *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av)); + defavp = &GvAV(PL_defgv); + cx->blk_sub.savearray = *defavp; + *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av)); /* it's the responsibility of whoever leaves a sub to ensure * that a clean, empty AV is left in pad[0]. This is normally @@ -5181,7 +5181,7 @@ PP(pp_entersub) assert(!AvREAL(av) && AvFILLp(av) == -1); items = SP - MARK; - if (UNLIKELY(items - 1 > AvMAX(av))) { + if (UNLIKELY(items - 1 > AvMAX(av))) { SV **ary = AvALLOC(av); Renew(ary, items, SV*); AvMAX(av) = items - 1; @@ -5191,94 +5191,94 @@ PP(pp_entersub) if (items) Copy(MARK+1,AvARRAY(av),items,SV*); - AvFILLp(av) = items - 1; - } - if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && - !CvLVALUE(cv))) + AvFILLp(av) = items - 1; + } + if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && + !CvLVALUE(cv))) DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf, SVfARG(cv_name(cv, NULL, 0))); - /* warning must come *after* we fully set up the context - * stuff so that __WARN__ handlers can safely dounwind() - * if they want to - */ - if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN + /* warning must come *after* we fully set up the context + * stuff so that __WARN__ handlers can safely dounwind() + * if they want to + */ + if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION) && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))) - sub_crush_depth(cv); - RETURNOP(CvSTART(cv)); + sub_crush_depth(cv); + RETURNOP(CvSTART(cv)); } else { - SSize_t markix = TOPMARK; + SSize_t markix = TOPMARK; bool is_scalar; ENTER; /* pretend we did the ENTER earlier */ - PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix; + PL_scopestack[PL_scopestack_ix - 1] = old_savestack_ix; - SAVETMPS; - PUTBACK; + SAVETMPS; + PUTBACK; - if (UNLIKELY(((PL_op->op_private - & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub) + if (UNLIKELY(((PL_op->op_private + & CX_PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub) ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO && - !CvLVALUE(cv))) + !CvLVALUE(cv))) DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%" SVf, SVfARG(cv_name(cv, NULL, 0))); - if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) { - /* Need to copy @_ to stack. Alternative may be to - * switch stack to @_, and copy return values - * back. This would allow popping @_ in XSUB, e.g.. XXXX */ - AV * const av = GvAV(PL_defgv); - const SSize_t items = AvFILL(av) + 1; - - if (items) { - SSize_t i = 0; - const bool m = cBOOL(SvRMAGICAL(av)); - /* Mark is at the end of the stack. */ - EXTEND(SP, items); - for (; i < items; ++i) - { - SV *sv; - if (m) { - SV ** const svp = av_fetch(av, i, 0); - sv = svp ? *svp : NULL; - } - else sv = AvARRAY(av)[i]; - if (sv) SP[i+1] = sv; - else { - SP[i+1] = av_nonelem(av, i); - } - } - SP += items; - PUTBACK ; - } - } - else { - SV **mark = PL_stack_base + markix; - SSize_t items = SP - mark; - while (items--) { - mark++; - if (*mark && SvPADTMP(*mark)) { - *mark = sv_mortalcopy(*mark); + if (UNLIKELY(!(PL_op->op_flags & OPf_STACKED) && GvAV(PL_defgv))) { + /* Need to copy @_ to stack. Alternative may be to + * switch stack to @_, and copy return values + * back. This would allow popping @_ in XSUB, e.g.. XXXX */ + AV * const av = GvAV(PL_defgv); + const SSize_t items = AvFILL(av) + 1; + + if (items) { + SSize_t i = 0; + const bool m = cBOOL(SvRMAGICAL(av)); + /* Mark is at the end of the stack. */ + EXTEND(SP, items); + for (; i < items; ++i) + { + SV *sv; + if (m) { + SV ** const svp = av_fetch(av, i, 0); + sv = svp ? *svp : NULL; + } + else sv = AvARRAY(av)[i]; + if (sv) SP[i+1] = sv; + else { + SP[i+1] = av_nonelem(av, i); + } + } + SP += items; + PUTBACK ; + } + } + else { + SV **mark = PL_stack_base + markix; + SSize_t items = SP - mark; + while (items--) { + mark++; + if (*mark && SvPADTMP(*mark)) { + *mark = sv_mortalcopy(*mark); } - } - } - /* We assume first XSUB in &DB::sub is the called one. */ - if (UNLIKELY(PL_curcopdb)) { - SAVEVPTR(PL_curcop); - PL_curcop = PL_curcopdb; - PL_curcopdb = NULL; - } - /* Do we need to open block here? XXXX */ + } + } + /* We assume first XSUB in &DB::sub is the called one. */ + if (UNLIKELY(PL_curcopdb)) { + SAVEVPTR(PL_curcop); + PL_curcop = PL_curcopdb; + PL_curcopdb = NULL; + } + /* Do we need to open block here? XXXX */ /* calculate gimme here as PL_op might get changed and then not * restored until the LEAVE further down */ is_scalar = (GIMME_V == G_SCALAR); - /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */ - assert(CvXSUB(cv)); - CvXSUB(cv)(aTHX_ cv); + /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */ + assert(CvXSUB(cv)); + CvXSUB(cv)(aTHX_ cv); #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY /* This duplicates the check done in runops_debug(), but provides more @@ -5295,16 +5295,16 @@ PP(pp_entersub) PL_stack_base, PL_stack_sp, PL_stack_base + PL_curstackinfo->si_stack_hwm); #endif - /* Enforce some sanity in scalar context. */ - if (is_scalar) { + /* Enforce some sanity in scalar context. */ + if (is_scalar) { SV **svp = PL_stack_base + markix + 1; if (svp != PL_stack_sp) { *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp; PL_stack_sp = svp; } - } - LEAVE; - return NORMAL; + } + LEAVE; + return NORMAL; } } @@ -5314,10 +5314,10 @@ Perl_sub_crush_depth(pTHX_ CV *cv) PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH; if (CvANON(cv)) - Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); + Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { - Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"", - SVfARG(cv_name(cv,NULL,0))); + Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%" SVf "\"", + SVfARG(cv_name(cv,NULL,0))); } } @@ -5357,70 +5357,70 @@ PP(pp_aelem) SV *sv; if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Use of reference \"%" SVf "\" as array index", - SVfARG(elemsv)); + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Use of reference \"%" SVf "\" as array index", + SVfARG(elemsv)); if (UNLIKELY(SvTYPE(av) != SVt_PVAV)) - RETPUSHUNDEF; + RETPUSHUNDEF; if (UNLIKELY(localizing)) { - MAGIC *mg; - HV *stash; + MAGIC *mg; + HV *stash; - /* If we can determine whether the element exist, - * Try to preserve the existenceness of a tied array - * element by using EXISTS and DELETE if possible. - * Fallback to FETCH and STORE otherwise. */ - if (SvCANEXISTDELETE(av)) - preeminent = av_exists(av, elem); + /* If we can determine whether the element exist, + * Try to preserve the existenceness of a tied array + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise. */ + if (SvCANEXISTDELETE(av)) + preeminent = av_exists(av, elem); } svp = av_fetch(av, elem, lval && !defer); if (lval) { #ifdef PERL_MALLOC_WRAP - if (SvUOK(elemsv)) { - const UV uv = SvUV(elemsv); - elem = uv > IV_MAX ? IV_MAX : uv; - } - else if (SvNOK(elemsv)) - elem = (IV)SvNV(elemsv); - if (elem > 0) { - MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend"); - } + if (SvUOK(elemsv)) { + const UV uv = SvUV(elemsv); + elem = uv > IV_MAX ? IV_MAX : uv; + } + else if (SvNOK(elemsv)) + elem = (IV)SvNV(elemsv); + if (elem > 0) { + MEM_WRAP_CHECK_s(elem,SV*,"Out of memory during array extend"); + } #endif - if (!svp || !*svp) { - IV len; - if (!defer) - DIE(aTHX_ PL_no_aelem, elem); - len = av_top_index(av); - /* Resolve a negative index that falls within the array. Leave - it negative it if falls outside the array. */ - if (elem < 0 && len + elem >= 0) - elem = len + elem; - if (elem >= 0 && elem <= len) - /* Falls within the array. */ - PUSHs(av_nonelem(av,elem)); - else - /* Falls outside the array. If it is negative, - magic_setdefelem will use the index for error reporting. - */ - mPUSHs(newSVavdefelem(av, elem, 1)); - RETURN; - } - if (UNLIKELY(localizing)) { - if (preeminent) - save_aelem(av, elem, svp); - else - SAVEADELETE(av, elem); - } - else if (PL_op->op_private & OPpDEREF) { - PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF)); - RETURN; - } + if (!svp || !*svp) { + IV len; + if (!defer) + DIE(aTHX_ PL_no_aelem, elem); + len = av_top_index(av); + /* Resolve a negative index that falls within the array. Leave + it negative it if falls outside the array. */ + if (elem < 0 && len + elem >= 0) + elem = len + elem; + if (elem >= 0 && elem <= len) + /* Falls within the array. */ + PUSHs(av_nonelem(av,elem)); + else + /* Falls outside the array. If it is negative, + magic_setdefelem will use the index for error reporting. + */ + mPUSHs(newSVavdefelem(av, elem, 1)); + RETURN; + } + if (UNLIKELY(localizing)) { + if (preeminent) + save_aelem(av, elem, svp); + else + SAVEADELETE(av, elem); + } + else if (PL_op->op_private & OPpDEREF) { + PUSHs(vivify_ref(*svp, PL_op->op_private & OPpDEREF)); + RETURN; + } } sv = (svp ? *svp : &PL_sv_undef); if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */ - mg_get(sv); + mg_get(sv); PUSHs(sv); RETURN; } @@ -5432,30 +5432,30 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what) SvGETMAGIC(sv); if (!SvOK(sv)) { - if (SvREADONLY(sv)) - Perl_croak_no_modify(); - prepare_SV_for_RV(sv); - switch (to_what) { - case OPpDEREF_SV: - SvRV_set(sv, newSV(0)); - break; - case OPpDEREF_AV: - SvRV_set(sv, MUTABLE_SV(newAV())); - break; - case OPpDEREF_HV: - SvRV_set(sv, MUTABLE_SV(newHV())); - break; - } - SvROK_on(sv); - SvSETMAGIC(sv); - SvGETMAGIC(sv); + if (SvREADONLY(sv)) + Perl_croak_no_modify(); + prepare_SV_for_RV(sv); + switch (to_what) { + case OPpDEREF_SV: + SvRV_set(sv, newSV(0)); + break; + case OPpDEREF_AV: + SvRV_set(sv, MUTABLE_SV(newAV())); + break; + case OPpDEREF_HV: + SvRV_set(sv, MUTABLE_SV(newHV())); + break; + } + SvROK_on(sv); + SvSETMAGIC(sv); + SvGETMAGIC(sv); } if (SvGMAGICAL(sv)) { - /* copy the sv without magic to prevent magic from being - executed twice */ - SV* msv = sv_newmortal(); - sv_setsv_nomg(msv, sv); - return msv; + /* copy the sv without magic to prevent magic from being + executed twice */ + SV* msv = sv_newmortal(); + sv_setsv_nomg(msv, sv); + return msv; } return sv; } @@ -5467,78 +5467,78 @@ S_opmethod_stash(pTHX_ SV* meth) HV* stash; SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp - ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a " - "package or object reference", SVfARG(meth)), - (SV *)NULL) - : *(PL_stack_base + TOPMARK + 1); + ? (Perl_croak(aTHX_ "Can't call method \"%" SVf "\" without a " + "package or object reference", SVfARG(meth)), + (SV *)NULL) + : *(PL_stack_base + TOPMARK + 1); PERL_ARGS_ASSERT_OPMETHOD_STASH; if (UNLIKELY(!sv)) undefined: - Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value", - SVfARG(meth)); + Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on an undefined value", + SVfARG(meth)); if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv); else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */ - stash = gv_stashsv(sv, GV_CACHE_ONLY); - if (stash) return stash; + stash = gv_stashsv(sv, GV_CACHE_ONLY); + if (stash) return stash; } if (SvROK(sv)) - ob = MUTABLE_SV(SvRV(sv)); + ob = MUTABLE_SV(SvRV(sv)); else if (!SvOK(sv)) goto undefined; else if (isGV_with_GP(sv)) { - if (!GvIO(sv)) - Perl_croak(aTHX_ "Can't call method \"%" SVf "\" " - "without a package or object reference", - SVfARG(meth)); - ob = sv; - if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') { - assert(!LvTARGLEN(ob)); - ob = LvTARG(ob); - assert(ob); - } - *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob)); + if (!GvIO(sv)) + Perl_croak(aTHX_ "Can't call method \"%" SVf "\" " + "without a package or object reference", + SVfARG(meth)); + ob = sv; + if (SvTYPE(ob) == SVt_PVLV && LvTYPE(ob) == 'y') { + assert(!LvTARGLEN(ob)); + ob = LvTARG(ob); + assert(ob); + } + *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(ob)); } else { - /* this isn't a reference */ - GV* iogv; + /* this isn't a reference */ + GV* iogv; STRLEN packlen; const char * const packname = SvPV_nomg_const(sv, packlen); const U32 packname_utf8 = SvUTF8(sv); stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY); if (stash) return stash; - if (!(iogv = gv_fetchpvn_flags( - packname, packlen, packname_utf8, SVt_PVIO - )) || - !(ob=MUTABLE_SV(GvIO(iogv)))) - { - /* this isn't the name of a filehandle either */ - if (!packlen) - { - Perl_croak(aTHX_ "Can't call method \"%" SVf "\" " - "without a package or object reference", - SVfARG(meth)); - } - /* assume it's a package name */ - stash = gv_stashpvn(packname, packlen, packname_utf8); - if (stash) return stash; - else return MUTABLE_HV(sv); - } - /* it _is_ a filehandle name -- replace with a reference */ - *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv))); + if (!(iogv = gv_fetchpvn_flags( + packname, packlen, packname_utf8, SVt_PVIO + )) || + !(ob=MUTABLE_SV(GvIO(iogv)))) + { + /* this isn't the name of a filehandle either */ + if (!packlen) + { + Perl_croak(aTHX_ "Can't call method \"%" SVf "\" " + "without a package or object reference", + SVfARG(meth)); + } + /* assume it's a package name */ + stash = gv_stashpvn(packname, packlen, packname_utf8); + if (stash) return stash; + else return MUTABLE_HV(sv); + } + /* it _is_ a filehandle name -- replace with a reference */ + *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv))); } /* if we got here, ob should be an object or a glob */ if (!ob || !(SvOBJECT(ob) - || (isGV_with_GP(ob) - && (ob = MUTABLE_SV(GvIO((const GV *)ob))) - && SvOBJECT(ob)))) + || (isGV_with_GP(ob) + && (ob = MUTABLE_SV(GvIO((const GV *)ob))) + && SvOBJECT(ob)))) { - Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference", - SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES) + Perl_croak(aTHX_ "Can't call method \"%" SVf "\" on unblessed reference", + SVfARG((SvPOK(meth) && SvPVX(meth) == PL_isa_DOES) ? newSVpvs_flags("DOES", SVs_TEMP) : meth)); } @@ -56,18 +56,18 @@ typedef struct tempsym { #define TEMPSYM_INIT(symptr, p, e, f) \ STMT_START { \ - (symptr)->patptr = (p); \ - (symptr)->patend = (e); \ - (symptr)->grpbeg = NULL; \ - (symptr)->grpend = NULL; \ - (symptr)->grpend = NULL; \ - (symptr)->code = 0; \ - (symptr)->length = 0; \ - (symptr)->howlen = e_no_len; \ - (symptr)->level = 0; \ - (symptr)->flags = (f); \ - (symptr)->strbeg = 0; \ - (symptr)->previous = NULL; \ + (symptr)->patptr = (p); \ + (symptr)->patend = (e); \ + (symptr)->grpbeg = NULL; \ + (symptr)->grpend = NULL; \ + (symptr)->grpend = NULL; \ + (symptr)->code = 0; \ + (symptr)->length = 0; \ + (symptr)->howlen = e_no_len; \ + (symptr)->level = 0; \ + (symptr)->flags = (f); \ + (symptr)->strbeg = 0; \ + (symptr)->previous = NULL; \ } STMT_END typedef union { @@ -148,7 +148,7 @@ typedef union { STMT_START { \ if (UNLIKELY(utf8)) { \ if (!S_utf8_to_bytes(aTHX_ &s, strend, \ - (char *) (buf), len, datumtype)) break; \ + (char *) (buf), len, datumtype)) break; \ } else { \ if (UNLIKELY(needs_swap)) \ S_reverse_copy(s, (char *) (buf), len); \ @@ -251,27 +251,27 @@ utf8_to_byte(pTHX_ const char **s, const char *end, I32 datumtype) UV val; if (*s >= end) { - goto croak; + goto croak; } val = utf8n_to_uvchr((U8 *) *s, end-*s, &retlen, - ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); + ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); if (retlen == (STRLEN) -1) croak: - Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack", - (int) TYPE_NO_MODIFIERS(datumtype)); + Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack", + (int) TYPE_NO_MODIFIERS(datumtype)); if (val >= 0x100) { - Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK), - "Character in '%c' format wrapped in unpack", - (int) TYPE_NO_MODIFIERS(datumtype)); - val &= 0xff; + Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK), + "Character in '%c' format wrapped in unpack", + (int) TYPE_NO_MODIFIERS(datumtype)); + val &= 0xff; } *s += retlen; return (U8)val; } #define SHIFT_BYTE(utf8, s, strend, datumtype) ((utf8) ? \ - utf8_to_byte(aTHX_ &(s), (strend), (datumtype)) : \ - *(U8 *)(s)++) + utf8_to_byte(aTHX_ &(s), (strend), (datumtype)) : \ + *(U8 *)(s)++) STATIC bool S_utf8_to_bytes(pTHX_ const char **s, const char *end, const char *buf, SSize_t buf_len, I32 datumtype) @@ -281,23 +281,23 @@ S_utf8_to_bytes(pTHX_ const char **s, const char *end, const char *buf, SSize_t const char *from = *s; int bad = 0; const U32 flags = ckWARN(WARN_UTF8) ? - UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY); + UTF8_CHECK_ONLY : (UTF8_CHECK_ONLY | UTF8_ALLOW_ANY); const bool needs_swap = NEEDS_SWAP(datumtype); if (UNLIKELY(needs_swap)) buf += buf_len; for (;buf_len > 0; buf_len--) { - if (from >= end) return FALSE; - val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags); - if (retlen == (STRLEN) -1) { - from += UTF8_SAFE_SKIP(from, end); - bad |= 1; - } else from += retlen; - if (val >= 0x100) { - bad |= 2; - val &= 0xff; - } + if (from >= end) return FALSE; + val = utf8n_to_uvchr((U8 *) from, end-from, &retlen, flags); + if (retlen == (STRLEN) -1) { + from += UTF8_SAFE_SKIP(from, end); + bad |= 1; + } else from += retlen; + if (val >= 0x100) { + bad |= 2; + val &= 0xff; + } if (UNLIKELY(needs_swap)) *(U8 *)--buf = (U8)val; else @@ -305,22 +305,22 @@ S_utf8_to_bytes(pTHX_ const char **s, const char *end, const char *buf, SSize_t } /* We have enough characters for the buffer. Did we have problems ? */ if (bad) { - if (bad & 1) { - /* Rewalk the string fragment while warning */ - const char *ptr; - const U32 flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; - for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) { - if (ptr >= end) break; - utf8n_to_uvchr((U8 *) ptr, end-ptr, &retlen, flags); - } - if (from > end) from = end; - } - if ((bad & 2)) - Perl_ck_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ? - WARN_PACK : WARN_UNPACK), - "Character(s) in '%c' format wrapped in %s", - (int) TYPE_NO_MODIFIERS(datumtype), - datumtype & TYPE_IS_PACK ? "pack" : "unpack"); + if (bad & 1) { + /* Rewalk the string fragment while warning */ + const char *ptr; + const U32 flags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY; + for (ptr = *s; ptr < from; ptr += UTF8SKIP(ptr)) { + if (ptr >= end) break; + utf8n_to_uvchr((U8 *) ptr, end-ptr, &retlen, flags); + } + if (from > end) from = end; + } + if ((bad & 2)) + Perl_ck_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ? + WARN_PACK : WARN_UNPACK), + "Character(s) in '%c' format wrapped in %s", + (int) TYPE_NO_MODIFIERS(datumtype), + datumtype & TYPE_IS_PACK ? "pack" : "unpack"); } *s = from; return TRUE; @@ -348,13 +348,13 @@ S_my_bytes_to_utf8(const U8 *start, STRLEN len, char *dest, const bool needs_swa #define PUSH_BYTES(utf8, cur, buf, len, needs_swap) \ STMT_START { \ if (UNLIKELY(utf8)) \ - (cur) = my_bytes_to_utf8((U8 *) buf, len, (cur), needs_swap); \ + (cur) = my_bytes_to_utf8((U8 *) buf, len, (cur), needs_swap); \ else { \ if (UNLIKELY(needs_swap)) \ S_reverse_copy((char *)(buf), cur, len); \ else \ Copy(buf, cur, len, char); \ - (cur) += (len); \ + (cur) += (len); \ } \ } STMT_END @@ -380,8 +380,8 @@ STMT_START { \ if (SSize_t_MAX - glen < catcur) \ Perl_croak(aTHX_ "%s", "Out of memory during pack()"); \ if (catcur + glen >= SvLEN(cat)) { \ - (start) = sv_exp_grow(cat, glen); \ - (cur) = (start) + SvCUR(cat); \ + (start) = sv_exp_grow(cat, glen); \ + (cur) = (start) + SvCUR(cat); \ } \ } STMT_END @@ -393,8 +393,8 @@ STMT_START { \ if ((cur) + gl >= (start) + SvLEN(cat)) { \ *cur = '\0'; \ SvCUR_set((cat), (cur) - (start)); \ - (start) = sv_exp_grow(cat, gl); \ - (cur) = (start) + SvCUR(cat); \ + (start) = sv_exp_grow(cat, gl); \ + (cur) = (start) + SvCUR(cat); \ } \ PUSH_BYTES(utf8, cur, buf, glen, 0); \ } STMT_END @@ -402,8 +402,8 @@ STMT_START { \ #define PUSH_BYTE(utf8, s, byte) \ STMT_START { \ if (utf8) { \ - const U8 au8 = (byte); \ - (s) = my_bytes_to_utf8(&au8, 1, (s), 0);\ + const U8 au8 = (byte); \ + (s) = my_bytes_to_utf8(&au8, 1, (s), 0);\ } else *(U8 *)(s)++ = (byte); \ } STMT_END @@ -414,8 +414,8 @@ STMT_START { \ if (str >= end) break; \ val = utf8n_to_uvchr((U8 *) str, end-str, &retlen, utf8_flags); \ if (retlen == (STRLEN) -1) { \ - *cur = '\0'; \ - Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); \ + *cur = '\0'; \ + Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); \ } \ str += retlen; \ } STMT_END @@ -434,100 +434,100 @@ S_measure_struct(pTHX_ tempsym_t* symptr) PERL_ARGS_ASSERT_MEASURE_STRUCT; while (next_symbol(symptr)) { - SSize_t len, size; + SSize_t len, size; switch (symptr->howlen) { - case e_star: - Perl_croak(aTHX_ "Within []-length '*' not allowed in %s", + case e_star: + Perl_croak(aTHX_ "Within []-length '*' not allowed in %s", _action( symptr ) ); - default: - /* e_no_len and e_number */ - len = symptr->length; - break; + default: + /* e_no_len and e_number */ + len = symptr->length; + break; } - size = packprops[TYPE_NO_ENDIANNESS(symptr->code)] & PACK_SIZE_MASK; - if (!size) { + size = packprops[TYPE_NO_ENDIANNESS(symptr->code)] & PACK_SIZE_MASK; + if (!size) { SSize_t star; - /* endianness doesn't influence the size of a type */ - switch(TYPE_NO_ENDIANNESS(symptr->code)) { - default: - Perl_croak(aTHX_ "Invalid type '%c' in %s", - (int)TYPE_NO_MODIFIERS(symptr->code), + /* endianness doesn't influence the size of a type */ + switch(TYPE_NO_ENDIANNESS(symptr->code)) { + default: + Perl_croak(aTHX_ "Invalid type '%c' in %s", + (int)TYPE_NO_MODIFIERS(symptr->code), _action( symptr ) ); - case '.' | TYPE_IS_SHRIEKING: - case '@' | TYPE_IS_SHRIEKING: - case '@': - case '.': - case '/': - case 'U': /* XXXX Is it correct? */ - case 'w': - case 'u': - Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s", - (int) TYPE_NO_MODIFIERS(symptr->code), + case '.' | TYPE_IS_SHRIEKING: + case '@' | TYPE_IS_SHRIEKING: + case '@': + case '.': + case '/': + case 'U': /* XXXX Is it correct? */ + case 'w': + case 'u': + Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s", + (int) TYPE_NO_MODIFIERS(symptr->code), _action( symptr ) ); - case '%': - size = 0; - break; - case '(': - { - tempsym_t savsym = *symptr; - symptr->patptr = savsym.grpbeg; - symptr->patend = savsym.grpend; - /* XXXX Theoretically, we need to measure many times at - different positions, since the subexpression may contain - alignment commands, but be not of aligned length. - Need to detect this and croak(). */ - size = measure_struct(symptr); - *symptr = savsym; - break; - } - case 'X' | TYPE_IS_SHRIEKING: - /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. - */ - if (!len) /* Avoid division by 0 */ - len = 1; - len = total % len; /* Assumed: the start is aligned. */ - /* FALLTHROUGH */ - case 'X': - size = -1; - if (total < len) + case '%': + size = 0; + break; + case '(': + { + tempsym_t savsym = *symptr; + symptr->patptr = savsym.grpbeg; + symptr->patend = savsym.grpend; + /* XXXX Theoretically, we need to measure many times at + different positions, since the subexpression may contain + alignment commands, but be not of aligned length. + Need to detect this and croak(). */ + size = measure_struct(symptr); + *symptr = savsym; + break; + } + case 'X' | TYPE_IS_SHRIEKING: + /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. + */ + if (!len) /* Avoid division by 0 */ + len = 1; + len = total % len; /* Assumed: the start is aligned. */ + /* FALLTHROUGH */ + case 'X': + size = -1; + if (total < len) Perl_croak(aTHX_ "'X' outside of string in %s", _action( symptr ) ); - break; - case 'x' | TYPE_IS_SHRIEKING: - if (!len) /* Avoid division by 0 */ - len = 1; - star = total % len; /* Assumed: the start is aligned. */ - if (star) /* Other portable ways? */ - len = len - star; - else - len = 0; - /* FALLTHROUGH */ - case 'x': - case 'A': - case 'Z': - case 'a': - size = 1; - break; - case 'B': - case 'b': - len = (len + 7)/8; - size = 1; - break; - case 'H': - case 'h': - len = (len + 1)/2; - size = 1; - break; - - case 'P': - len = 1; - size = sizeof(char*); - break; - } - } - total += len * size; + break; + case 'x' | TYPE_IS_SHRIEKING: + if (!len) /* Avoid division by 0 */ + len = 1; + star = total % len; /* Assumed: the start is aligned. */ + if (star) /* Other portable ways? */ + len = len - star; + else + len = 0; + /* FALLTHROUGH */ + case 'x': + case 'A': + case 'Z': + case 'a': + size = 1; + break; + case 'B': + case 'b': + len = (len + 7)/8; + size = 1; + break; + case 'H': + case 'h': + len = (len + 1)/2; + size = 1; + break; + + case 'P': + len = 1; + size = sizeof(char*); + break; + } + } + total += len * size; } return total; } @@ -542,20 +542,20 @@ S_group_end(pTHX_ const char *patptr, const char *patend, char ender) PERL_ARGS_ASSERT_GROUP_END; while (patptr < patend) { - const char c = *patptr++; - - if (isSPACE(c)) - continue; - else if (c == ender) - return patptr-1; - else if (c == '#') { - while (patptr < patend && *patptr != '\n') - patptr++; - continue; - } else if (c == '(') - patptr = group_end(patptr, patend, ')') + 1; - else if (c == '[') - patptr = group_end(patptr, patend, ']') + 1; + const char c = *patptr++; + + if (isSPACE(c)) + continue; + else if (c == ender) + return patptr-1; + else if (c == '#') { + while (patptr < patend && *patptr != '\n') + patptr++; + continue; + } else if (c == '(') + patptr = group_end(patptr, patend, ')') + 1; + else if (c == '[') + patptr = group_end(patptr, patend, ']') + 1; } Perl_croak(aTHX_ "No group ending character '%c' found in template", ender); @@ -603,21 +603,21 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) else if (*patptr == '#') { patptr++; while (patptr < patend && *patptr != '\n') - patptr++; + patptr++; if (patptr < patend) - patptr++; + patptr++; } else { /* We should have found a template code */ I32 code = *patptr++ & 0xFF; U32 inherited_modifiers = 0; if (code == ','){ /* grandfather in commas but with a warning */ - if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){ + if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){ symptr->flags |= FLAG_COMMA; - Perl_warner(aTHX_ packWARN(WARN_UNPACK), - "Invalid type ',' in %s", _action( symptr ) ); + Perl_warner(aTHX_ packWARN(WARN_UNPACK), + "Invalid type ',' in %s", _action( symptr ) ); } - continue; + continue; } /* for '(', skip to ')' */ @@ -628,7 +628,7 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) symptr->grpbeg = patptr; patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') ); if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL ) - Perl_croak(aTHX_ "Too deeply nested ()-groups in %s", + Perl_croak(aTHX_ "Too deeply nested ()-groups in %s", _action( symptr ) ); } @@ -677,10 +677,10 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) *patptr, _action( symptr ) ); if ((code & modifier)) { - Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK), - "Duplicate modifier '%c' after '%c' in %s", - *patptr, (int) TYPE_NO_MODIFIERS(code), - _action( symptr ) ); + Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK), + "Duplicate modifier '%c' after '%c' in %s", + *patptr, (int) TYPE_NO_MODIFIERS(code), + _action( symptr ) ); } code |= modifier; @@ -692,8 +692,8 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) /* look for count and/or / */ if (patptr < patend) { - if (isDIGIT(*patptr)) { - patptr = get_num( patptr, &symptr->length ); + if (isDIGIT(*patptr)) { + patptr = get_num( patptr, &symptr->length ); symptr->howlen = e_number; } else if (*patptr == '*') { @@ -729,9 +729,9 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) else if (*patptr == '#') { patptr++; while (patptr < patend && *patptr != '\n') - patptr++; + patptr++; if (patptr < patend) - patptr++; + patptr++; } else { if (*patptr == '/') { symptr->flags |= FLAG_SLASH; @@ -742,8 +742,8 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) _action( symptr ) ); } break; - } - } + } + } } else { /* at end - no count, no / */ symptr->howlen = e_no_len; @@ -776,14 +776,14 @@ need_utf8(const char *pat, const char *patend) PERL_ARGS_ASSERT_NEED_UTF8; while (pat < patend) { - if (pat[0] == '#') { - pat++; - pat = (const char *) memchr(pat, '\n', patend-pat); - if (!pat) return FALSE; - } else if (pat[0] == 'U') { - if (first || pat[1] == '0') return TRUE; - } else first = FALSE; - pat++; + if (pat[0] == '#') { + pat++; + pat = (const char *) memchr(pat, '\n', patend-pat); + if (!pat) return FALSE; + } else if (pat[0] == 'U') { + if (first || pat[1] == '0') return TRUE; + } else first = FALSE; + pat++; } return FALSE; } @@ -793,11 +793,11 @@ first_symbol(const char *pat, const char *patend) { PERL_ARGS_ASSERT_FIRST_SYMBOL; while (pat < patend) { - if (pat[0] != '#') return pat[0]; - pat++; - pat = (const char *) memchr(pat, '\n', patend-pat); - if (!pat) return 0; - pat++; + if (pat[0] != '#') return pat[0]; + pat++; + pat = (const char *) memchr(pat, '\n', patend-pat); + if (!pat) return 0; + pat++; } return 0; } @@ -833,17 +833,17 @@ Perl_unpackstring(pTHX_ const char *pat, const char *patend, const char *s, cons if (flags & FLAG_DO_UTF8) flags |= FLAG_WAS_UTF8; else if (need_utf8(pat, patend)) { - /* We probably should try to avoid this in case a scalar context call - wouldn't get to the "U0" */ - STRLEN len = strend - s; - s = (char *) bytes_to_utf8((U8 *) s, &len); - SAVEFREEPV(s); - strend = s + len; - flags |= FLAG_DO_UTF8; + /* We probably should try to avoid this in case a scalar context call + wouldn't get to the "U0" */ + STRLEN len = strend - s; + s = (char *) bytes_to_utf8((U8 *) s, &len); + SAVEFREEPV(s); + strend = s + len; + flags |= FLAG_DO_UTF8; } if (first_symbol(pat, patend) != 'U' && (flags & FLAG_DO_UTF8)) - flags |= FLAG_PARSE_UTF8; + flags |= FLAG_PARSE_UTF8; TEMPSYM_INIT(&sym, pat, patend, flags); @@ -871,223 +871,223 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c symptr->strbeg = s - strbeg; while (next_symbol(symptr)) { - packprops_t props; - SSize_t len; + packprops_t props; + SSize_t len; I32 datumtype = symptr->code; bool needs_swap; - /* do first one only unless in list context - / is implemented by unpacking the count, then popping it from the - stack, so must check that we're not in the middle of a / */ + /* do first one only unless in list context + / is implemented by unpacking the count, then popping it from the + stack, so must check that we're not in the middle of a / */ if ( unpack_only_one - && (SP - PL_stack_base == start_sp_offset + 1) - && (datumtype != '/') ) /* XXX can this be omitted */ + && (SP - PL_stack_base == start_sp_offset + 1) + && (datumtype != '/') ) /* XXX can this be omitted */ break; switch (howlen = symptr->howlen) { - case e_star: - len = strend - strbeg; /* long enough */ - break; - default: - /* e_no_len and e_number */ - len = symptr->length; - break; + case e_star: + len = strend - strbeg; /* long enough */ + break; + default: + /* e_no_len and e_number */ + len = symptr->length; + break; } explicit_length = TRUE; redo_switch: beyond = s >= strend; - props = packprops[TYPE_NO_ENDIANNESS(datumtype)]; - if (props) { - /* props nonzero means we can process this letter. */ + props = packprops[TYPE_NO_ENDIANNESS(datumtype)]; + if (props) { + /* props nonzero means we can process this letter. */ const SSize_t size = props & PACK_SIZE_MASK; const SSize_t howmany = (strend - s) / size; - if (len > howmany) - len = howmany; + if (len > howmany) + len = howmany; - if (!checksum || (props & PACK_SIZE_CANNOT_CSUM)) { - if (len && unpack_only_one) len = 1; - EXTEND(SP, len); - EXTEND_MORTAL(len); - } - } + if (!checksum || (props & PACK_SIZE_CANNOT_CSUM)) { + if (len && unpack_only_one) len = 1; + EXTEND(SP, len); + EXTEND_MORTAL(len); + } + } needs_swap = NEEDS_SWAP(datumtype); - switch(TYPE_NO_ENDIANNESS(datumtype)) { - default: - Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) ); + switch(TYPE_NO_ENDIANNESS(datumtype)) { + default: + Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)TYPE_NO_MODIFIERS(datumtype) ); - case '%': - if (howlen == e_no_len) - len = 16; /* len is not specified */ - checksum = len; - cuv = 0; - cdouble = 0; - continue; + case '%': + if (howlen == e_no_len) + len = 16; /* len is not specified */ + checksum = len; + cuv = 0; + cdouble = 0; + continue; - case '(': - { + case '(': + { tempsym_t savsym = *symptr; const U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags); - symptr->flags |= group_modifiers; + symptr->flags |= group_modifiers; symptr->patend = savsym.grpend; - symptr->previous = &savsym; + symptr->previous = &savsym; symptr->level++; - PUTBACK; - if (len && unpack_only_one) len = 1; - while (len--) { - symptr->patptr = savsym.grpbeg; - if (utf8) symptr->flags |= FLAG_PARSE_UTF8; - else symptr->flags &= ~FLAG_PARSE_UTF8; - unpack_rec(symptr, s, strbeg, strend, &s); + PUTBACK; + if (len && unpack_only_one) len = 1; + while (len--) { + symptr->patptr = savsym.grpbeg; + if (utf8) symptr->flags |= FLAG_PARSE_UTF8; + else symptr->flags &= ~FLAG_PARSE_UTF8; + unpack_rec(symptr, s, strbeg, strend, &s); if (s == strend && savsym.howlen == e_star) - break; /* No way to continue */ - } - SPAGAIN; + break; /* No way to continue */ + } + SPAGAIN; savsym.flags = symptr->flags & ~group_modifiers; *symptr = savsym; - break; - } - case '.' | TYPE_IS_SHRIEKING: - case '.': { - const char *from; - SV *sv; - const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING); - if (howlen == e_star) from = strbeg; - else if (len <= 0) from = s; - else { - tempsym_t *group = symptr; - - while (--len && group) group = group->previous; - from = group ? strbeg + group->strbeg : strbeg; - } - sv = from <= s ? - newSVuv( u8 ? (UV) utf8_length((const U8*)from, (const U8*)s) : (UV) (s-from)) : - newSViv(-(u8 ? (IV) utf8_length((const U8*)s, (const U8*)from) : (IV) (from-s))); - mXPUSHs(sv); - break; - } - case '@' | TYPE_IS_SHRIEKING: - case '@': - s = strbeg + symptr->strbeg; - if (utf8 && !(datumtype & TYPE_IS_SHRIEKING)) - { - while (len > 0) { - if (s >= strend) - Perl_croak(aTHX_ "'@' outside of string in unpack"); - s += UTF8SKIP(s); - len--; - } - if (s > strend) - Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack"); - } else { - if (strend-s < len) - Perl_croak(aTHX_ "'@' outside of string in unpack"); - s += len; - } - break; - case 'X' | TYPE_IS_SHRIEKING: - if (!len) /* Avoid division by 0 */ - len = 1; - if (utf8) { - const char *hop, *last; - SSize_t l = len; - hop = last = strbeg; - while (hop < s) { - hop += UTF8SKIP(hop); - if (--l == 0) { - last = hop; - l = len; - } - } - if (last > s) - Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); - s = last; - break; - } - len = (s - strbeg) % len; - /* FALLTHROUGH */ - case 'X': - if (utf8) { - while (len > 0) { - if (s <= strbeg) - Perl_croak(aTHX_ "'X' outside of string in unpack"); - while (--s, UTF8_IS_CONTINUATION(*s)) { - if (s <= strbeg) - Perl_croak(aTHX_ "'X' outside of string in unpack"); - } - len--; - } - } else { - if (len > s - strbeg) - Perl_croak(aTHX_ "'X' outside of string in unpack" ); - s -= len; - } - break; - case 'x' | TYPE_IS_SHRIEKING: { + break; + } + case '.' | TYPE_IS_SHRIEKING: + case '.': { + const char *from; + SV *sv; + const bool u8 = utf8 && !(datumtype & TYPE_IS_SHRIEKING); + if (howlen == e_star) from = strbeg; + else if (len <= 0) from = s; + else { + tempsym_t *group = symptr; + + while (--len && group) group = group->previous; + from = group ? strbeg + group->strbeg : strbeg; + } + sv = from <= s ? + newSVuv( u8 ? (UV) utf8_length((const U8*)from, (const U8*)s) : (UV) (s-from)) : + newSViv(-(u8 ? (IV) utf8_length((const U8*)s, (const U8*)from) : (IV) (from-s))); + mXPUSHs(sv); + break; + } + case '@' | TYPE_IS_SHRIEKING: + case '@': + s = strbeg + symptr->strbeg; + if (utf8 && !(datumtype & TYPE_IS_SHRIEKING)) + { + while (len > 0) { + if (s >= strend) + Perl_croak(aTHX_ "'@' outside of string in unpack"); + s += UTF8SKIP(s); + len--; + } + if (s > strend) + Perl_croak(aTHX_ "'@' outside of string with malformed UTF-8 in unpack"); + } else { + if (strend-s < len) + Perl_croak(aTHX_ "'@' outside of string in unpack"); + s += len; + } + break; + case 'X' | TYPE_IS_SHRIEKING: + if (!len) /* Avoid division by 0 */ + len = 1; + if (utf8) { + const char *hop, *last; + SSize_t l = len; + hop = last = strbeg; + while (hop < s) { + hop += UTF8SKIP(hop); + if (--l == 0) { + last = hop; + l = len; + } + } + if (last > s) + Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); + s = last; + break; + } + len = (s - strbeg) % len; + /* FALLTHROUGH */ + case 'X': + if (utf8) { + while (len > 0) { + if (s <= strbeg) + Perl_croak(aTHX_ "'X' outside of string in unpack"); + while (--s, UTF8_IS_CONTINUATION(*s)) { + if (s <= strbeg) + Perl_croak(aTHX_ "'X' outside of string in unpack"); + } + len--; + } + } else { + if (len > s - strbeg) + Perl_croak(aTHX_ "'X' outside of string in unpack" ); + s -= len; + } + break; + case 'x' | TYPE_IS_SHRIEKING: { SSize_t ai32; - if (!len) /* Avoid division by 0 */ - len = 1; - if (utf8) ai32 = utf8_length((U8 *) strbeg, (U8 *) s) % len; - else ai32 = (s - strbeg) % len; - if (ai32 == 0) break; - len -= ai32; - } - /* FALLTHROUGH */ - case 'x': - if (utf8) { - while (len>0) { - if (s >= strend) - Perl_croak(aTHX_ "'x' outside of string in unpack"); - s += UTF8SKIP(s); - len--; - } - } else { - if (len > strend - s) - Perl_croak(aTHX_ "'x' outside of string in unpack"); - s += len; - } - break; - case '/': - Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); - - case 'A': - case 'Z': - case 'a': - if (checksum) { - /* Preliminary length estimate is assumed done in 'W' */ - if (len > strend - s) len = strend - s; - goto W_checksum; - } - if (utf8) { - SSize_t l; - const char *hop; - for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) { - if (hop >= strend) { - if (hop > strend) - Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); - break; - } - } - if (hop > strend) - Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); - len = hop - s; - } else if (len > strend - s) - len = strend - s; - - if (datumtype == 'Z') { - /* 'Z' strips stuff after first null */ - const char *ptr, *end; - end = s + len; - for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break; - sv = newSVpvn(s, ptr-s); - if (howlen == e_star) /* exact for 'Z*' */ - len = ptr-s + (ptr != strend ? 1 : 0); - } else if (datumtype == 'A') { - /* 'A' strips both nulls and spaces */ - const char *ptr; - if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) { + if (!len) /* Avoid division by 0 */ + len = 1; + if (utf8) ai32 = utf8_length((U8 *) strbeg, (U8 *) s) % len; + else ai32 = (s - strbeg) % len; + if (ai32 == 0) break; + len -= ai32; + } + /* FALLTHROUGH */ + case 'x': + if (utf8) { + while (len>0) { + if (s >= strend) + Perl_croak(aTHX_ "'x' outside of string in unpack"); + s += UTF8SKIP(s); + len--; + } + } else { + if (len > strend - s) + Perl_croak(aTHX_ "'x' outside of string in unpack"); + s += len; + } + break; + case '/': + Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); + + case 'A': + case 'Z': + case 'a': + if (checksum) { + /* Preliminary length estimate is assumed done in 'W' */ + if (len > strend - s) len = strend - s; + goto W_checksum; + } + if (utf8) { + SSize_t l; + const char *hop; + for (l=len, hop=s; l>0; l--, hop += UTF8SKIP(hop)) { + if (hop >= strend) { + if (hop > strend) + Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); + break; + } + } + if (hop > strend) + Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); + len = hop - s; + } else if (len > strend - s) + len = strend - s; + + if (datumtype == 'Z') { + /* 'Z' strips stuff after first null */ + const char *ptr, *end; + end = s + len; + for (ptr = s; ptr < end; ptr++) if (*ptr == 0) break; + sv = newSVpvn(s, ptr-s); + if (howlen == e_star) /* exact for 'Z*' */ + len = ptr-s + (ptr != strend ? 1 : 0); + } else if (datumtype == 'A') { + /* 'A' strips both nulls and spaces */ + const char *ptr; + if (utf8 && (symptr->flags & FLAG_WAS_UTF8)) { for (ptr = s+len-1; ptr >= s; ptr--) { if ( *ptr != 0 && !UTF8_IS_CONTINUATION(*ptr) @@ -1096,610 +1096,610 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c break; } } - if (ptr >= s) ptr += UTF8SKIP(ptr); - else ptr++; - if (ptr > s+len) - Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); - } else { - for (ptr = s+len-1; ptr >= s; ptr--) - if (*ptr != 0 && !isSPACE(*ptr)) break; - ptr++; - } - sv = newSVpvn(s, ptr-s); - } else sv = newSVpvn(s, len); - - if (utf8) { - SvUTF8_on(sv); - /* Undo any upgrade done due to need_utf8() */ - if (!(symptr->flags & FLAG_WAS_UTF8)) - sv_utf8_downgrade(sv, 0); - } - mXPUSHs(sv); - s += len; - break; - case 'B': - case 'b': { - char *str; - if (howlen == e_star || len > (strend - s) * 8) - len = (strend - s) * 8; - if (checksum) { - if (utf8) - while (len >= 8 && s < strend) { - cuv += PL_bitcount[utf8_to_byte(aTHX_ &s, strend, datumtype)]; - len -= 8; - } - else - while (len >= 8) { - cuv += PL_bitcount[*(U8 *)s++]; - len -= 8; - } - if (len && s < strend) { - U8 bits; - bits = SHIFT_BYTE(utf8, s, strend, datumtype); - if (datumtype == 'b') - while (len-- > 0) { - if (bits & 1) cuv++; - bits >>= 1; - } - else - while (len-- > 0) { - if (bits & 0x80) cuv++; - bits <<= 1; - } - } - break; - } - - sv = sv_2mortal(newSV(len ? len : 1)); - SvPOK_on(sv); - str = SvPVX(sv); - if (datumtype == 'b') { - U8 bits = 0; - const SSize_t ai32 = len; - for (len = 0; len < ai32; len++) { - if (len & 7) bits >>= 1; - else if (utf8) { - if (s >= strend) break; - bits = utf8_to_byte(aTHX_ &s, strend, datumtype); - } else bits = *(U8 *) s++; - *str++ = bits & 1 ? '1' : '0'; - } - } else { - U8 bits = 0; - const SSize_t ai32 = len; - for (len = 0; len < ai32; len++) { - if (len & 7) bits <<= 1; - else if (utf8) { - if (s >= strend) break; - bits = utf8_to_byte(aTHX_ &s, strend, datumtype); - } else bits = *(U8 *) s++; - *str++ = bits & 0x80 ? '1' : '0'; - } - } - *str = '\0'; - SvCUR_set(sv, str - SvPVX_const(sv)); - XPUSHs(sv); - break; - } - case 'H': - case 'h': { - char *str = NULL; - /* Preliminary length estimate, acceptable for utf8 too */ - if (howlen == e_star || len > (strend - s) * 2) - len = (strend - s) * 2; - if (!checksum) { - sv = sv_2mortal(newSV(len ? len : 1)); - SvPOK_on(sv); - str = SvPVX(sv); - } - if (datumtype == 'h') { - U8 bits = 0; - SSize_t ai32 = len; - for (len = 0; len < ai32; len++) { - if (len & 1) bits >>= 4; - else if (utf8) { - if (s >= strend) break; - bits = utf8_to_byte(aTHX_ &s, strend, datumtype); - } else bits = * (U8 *) s++; - if (!checksum) - *str++ = PL_hexdigit[bits & 15]; - } - } else { - U8 bits = 0; - const SSize_t ai32 = len; - for (len = 0; len < ai32; len++) { - if (len & 1) bits <<= 4; - else if (utf8) { - if (s >= strend) break; - bits = utf8_to_byte(aTHX_ &s, strend, datumtype); - } else bits = *(U8 *) s++; - if (!checksum) - *str++ = PL_hexdigit[(bits >> 4) & 15]; - } - } - if (!checksum) { - *str = '\0'; - SvCUR_set(sv, str - SvPVX_const(sv)); - XPUSHs(sv); - } - break; - } - case 'C': + if (ptr >= s) ptr += UTF8SKIP(ptr); + else ptr++; + if (ptr > s+len) + Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); + } else { + for (ptr = s+len-1; ptr >= s; ptr--) + if (*ptr != 0 && !isSPACE(*ptr)) break; + ptr++; + } + sv = newSVpvn(s, ptr-s); + } else sv = newSVpvn(s, len); + + if (utf8) { + SvUTF8_on(sv); + /* Undo any upgrade done due to need_utf8() */ + if (!(symptr->flags & FLAG_WAS_UTF8)) + sv_utf8_downgrade(sv, 0); + } + mXPUSHs(sv); + s += len; + break; + case 'B': + case 'b': { + char *str; + if (howlen == e_star || len > (strend - s) * 8) + len = (strend - s) * 8; + if (checksum) { + if (utf8) + while (len >= 8 && s < strend) { + cuv += PL_bitcount[utf8_to_byte(aTHX_ &s, strend, datumtype)]; + len -= 8; + } + else + while (len >= 8) { + cuv += PL_bitcount[*(U8 *)s++]; + len -= 8; + } + if (len && s < strend) { + U8 bits; + bits = SHIFT_BYTE(utf8, s, strend, datumtype); + if (datumtype == 'b') + while (len-- > 0) { + if (bits & 1) cuv++; + bits >>= 1; + } + else + while (len-- > 0) { + if (bits & 0x80) cuv++; + bits <<= 1; + } + } + break; + } + + sv = sv_2mortal(newSV(len ? len : 1)); + SvPOK_on(sv); + str = SvPVX(sv); + if (datumtype == 'b') { + U8 bits = 0; + const SSize_t ai32 = len; + for (len = 0; len < ai32; len++) { + if (len & 7) bits >>= 1; + else if (utf8) { + if (s >= strend) break; + bits = utf8_to_byte(aTHX_ &s, strend, datumtype); + } else bits = *(U8 *) s++; + *str++ = bits & 1 ? '1' : '0'; + } + } else { + U8 bits = 0; + const SSize_t ai32 = len; + for (len = 0; len < ai32; len++) { + if (len & 7) bits <<= 1; + else if (utf8) { + if (s >= strend) break; + bits = utf8_to_byte(aTHX_ &s, strend, datumtype); + } else bits = *(U8 *) s++; + *str++ = bits & 0x80 ? '1' : '0'; + } + } + *str = '\0'; + SvCUR_set(sv, str - SvPVX_const(sv)); + XPUSHs(sv); + break; + } + case 'H': + case 'h': { + char *str = NULL; + /* Preliminary length estimate, acceptable for utf8 too */ + if (howlen == e_star || len > (strend - s) * 2) + len = (strend - s) * 2; + if (!checksum) { + sv = sv_2mortal(newSV(len ? len : 1)); + SvPOK_on(sv); + str = SvPVX(sv); + } + if (datumtype == 'h') { + U8 bits = 0; + SSize_t ai32 = len; + for (len = 0; len < ai32; len++) { + if (len & 1) bits >>= 4; + else if (utf8) { + if (s >= strend) break; + bits = utf8_to_byte(aTHX_ &s, strend, datumtype); + } else bits = * (U8 *) s++; + if (!checksum) + *str++ = PL_hexdigit[bits & 15]; + } + } else { + U8 bits = 0; + const SSize_t ai32 = len; + for (len = 0; len < ai32; len++) { + if (len & 1) bits <<= 4; + else if (utf8) { + if (s >= strend) break; + bits = utf8_to_byte(aTHX_ &s, strend, datumtype); + } else bits = *(U8 *) s++; + if (!checksum) + *str++ = PL_hexdigit[(bits >> 4) & 15]; + } + } + if (!checksum) { + *str = '\0'; + SvCUR_set(sv, str - SvPVX_const(sv)); + XPUSHs(sv); + } + break; + } + case 'C': if (len == 0) { if (explicit_length) - /* Switch to "character" mode */ - utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; - break; - } - /* FALLTHROUGH */ - case 'c': - while (len-- > 0 && s < strend) { - int aint; - if (utf8) - { - STRLEN retlen; - aint = utf8n_to_uvchr((U8 *) s, strend-s, &retlen, - ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); - if (retlen == (STRLEN) -1) - Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); - s += retlen; - } - else - aint = *(U8 *)(s)++; - if (aint >= 128 && datumtype != 'C') /* fake up signed chars */ - aint -= 256; - if (!checksum) - mPUSHi(aint); - else if (checksum > bits_in_uv) - cdouble += (NV)aint; - else - cuv += aint; - } - break; - case 'W': - W_checksum: - if (utf8) { - while (len-- > 0 && s < strend) { - STRLEN retlen; - const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen, - ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); - if (retlen == (STRLEN) -1) - Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); - s += retlen; - if (!checksum) - mPUSHu(val); - else if (checksum > bits_in_uv) - cdouble += (NV) val; - else - cuv += val; - } - } else if (!checksum) - while (len-- > 0) { - const U8 ch = *(U8 *) s++; - mPUSHu(ch); - } - else if (checksum > bits_in_uv) - while (len-- > 0) cdouble += (NV) *(U8 *) s++; - else - while (len-- > 0) cuv += *(U8 *) s++; - break; - case 'U': - if (len == 0) { + /* Switch to "character" mode */ + utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; + break; + } + /* FALLTHROUGH */ + case 'c': + while (len-- > 0 && s < strend) { + int aint; + if (utf8) + { + STRLEN retlen; + aint = utf8n_to_uvchr((U8 *) s, strend-s, &retlen, + ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); + if (retlen == (STRLEN) -1) + Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); + s += retlen; + } + else + aint = *(U8 *)(s)++; + if (aint >= 128 && datumtype != 'C') /* fake up signed chars */ + aint -= 256; + if (!checksum) + mPUSHi(aint); + else if (checksum > bits_in_uv) + cdouble += (NV)aint; + else + cuv += aint; + } + break; + case 'W': + W_checksum: + if (utf8) { + while (len-- > 0 && s < strend) { + STRLEN retlen; + const UV val = utf8n_to_uvchr((U8 *) s, strend-s, &retlen, + ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY); + if (retlen == (STRLEN) -1) + Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); + s += retlen; + if (!checksum) + mPUSHu(val); + else if (checksum > bits_in_uv) + cdouble += (NV) val; + else + cuv += val; + } + } else if (!checksum) + while (len-- > 0) { + const U8 ch = *(U8 *) s++; + mPUSHu(ch); + } + else if (checksum > bits_in_uv) + while (len-- > 0) cdouble += (NV) *(U8 *) s++; + else + while (len-- > 0) cuv += *(U8 *) s++; + break; + case 'U': + if (len == 0) { if (explicit_length && howlen != e_star) { - /* Switch to "bytes in UTF-8" mode */ - if (symptr->flags & FLAG_DO_UTF8) utf8 = 0; - else - /* Should be impossible due to the need_utf8() test */ - Perl_croak(aTHX_ "U0 mode on a byte string"); - } - break; - } - if (len > strend - s) len = strend - s; - if (!checksum) { - if (len && unpack_only_one) len = 1; - EXTEND(SP, len); - EXTEND_MORTAL(len); - } - while (len-- > 0 && s < strend) { - STRLEN retlen; - UV auv; - if (utf8) { - U8 result[UTF8_MAXLEN+1]; - const char *ptr = s; - STRLEN len; - /* Bug: warns about bad utf8 even if we are short on bytes - and will break out of the loop */ - if (!S_utf8_to_bytes(aTHX_ &ptr, strend, (char *) result, 1, - 'U')) - break; - len = UTF8SKIP(result); - if (!S_utf8_to_bytes(aTHX_ &ptr, strend, - (char *) &result[1], len-1, 'U')) break; - auv = NATIVE_TO_UNI(utf8n_to_uvchr(result, + /* Switch to "bytes in UTF-8" mode */ + if (symptr->flags & FLAG_DO_UTF8) utf8 = 0; + else + /* Should be impossible due to the need_utf8() test */ + Perl_croak(aTHX_ "U0 mode on a byte string"); + } + break; + } + if (len > strend - s) len = strend - s; + if (!checksum) { + if (len && unpack_only_one) len = 1; + EXTEND(SP, len); + EXTEND_MORTAL(len); + } + while (len-- > 0 && s < strend) { + STRLEN retlen; + UV auv; + if (utf8) { + U8 result[UTF8_MAXLEN+1]; + const char *ptr = s; + STRLEN len; + /* Bug: warns about bad utf8 even if we are short on bytes + and will break out of the loop */ + if (!S_utf8_to_bytes(aTHX_ &ptr, strend, (char *) result, 1, + 'U')) + break; + len = UTF8SKIP(result); + if (!S_utf8_to_bytes(aTHX_ &ptr, strend, + (char *) &result[1], len-1, 'U')) break; + auv = NATIVE_TO_UNI(utf8n_to_uvchr(result, len, &retlen, UTF8_ALLOW_DEFAULT)); - s = ptr; - } else { - auv = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, + s = ptr; + } else { + auv = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &retlen, UTF8_ALLOW_DEFAULT)); - if (retlen == (STRLEN) -1) - Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); - s += retlen; - } - if (!checksum) - mPUSHu(auv); - else if (checksum > bits_in_uv) - cdouble += (NV) auv; - else - cuv += auv; - } - break; - case 's' | TYPE_IS_SHRIEKING: + if (retlen == (STRLEN) -1) + Perl_croak(aTHX_ "Malformed UTF-8 string in unpack"); + s += retlen; + } + if (!checksum) + mPUSHu(auv); + else if (checksum > bits_in_uv) + cdouble += (NV) auv; + else + cuv += auv; + } + break; + case 's' | TYPE_IS_SHRIEKING: #if SHORTSIZE != SIZE16 - while (len-- > 0) { - short ashort; + while (len-- > 0) { + short ashort; SHIFT_VAR(utf8, s, strend, ashort, datumtype, needs_swap); - if (!checksum) - mPUSHi(ashort); - else if (checksum > bits_in_uv) - cdouble += (NV)ashort; - else - cuv += ashort; - } - break; + if (!checksum) + mPUSHi(ashort); + else if (checksum > bits_in_uv) + cdouble += (NV)ashort; + else + cuv += ashort; + } + break; #else - /* FALLTHROUGH */ + /* FALLTHROUGH */ #endif - case 's': - while (len-- > 0) { - I16 ai16; + case 's': + while (len-- > 0) { + I16 ai16; #if U16SIZE > SIZE16 - ai16 = 0; + ai16 = 0; #endif SHIFT16(utf8, s, strend, &ai16, datumtype, needs_swap); #if U16SIZE > SIZE16 - if (ai16 > 32767) - ai16 -= 65536; + if (ai16 > 32767) + ai16 -= 65536; #endif - if (!checksum) - mPUSHi(ai16); - else if (checksum > bits_in_uv) - cdouble += (NV)ai16; - else - cuv += ai16; - } - break; - case 'S' | TYPE_IS_SHRIEKING: + if (!checksum) + mPUSHi(ai16); + else if (checksum > bits_in_uv) + cdouble += (NV)ai16; + else + cuv += ai16; + } + break; + case 'S' | TYPE_IS_SHRIEKING: #if SHORTSIZE != SIZE16 - while (len-- > 0) { - unsigned short aushort; - SHIFT_VAR(utf8, s, strend, aushort, datumtype, needs_swap); - if (!checksum) - mPUSHu(aushort); - else if (checksum > bits_in_uv) - cdouble += (NV)aushort; - else - cuv += aushort; - } - break; + while (len-- > 0) { + unsigned short aushort; + SHIFT_VAR(utf8, s, strend, aushort, datumtype, needs_swap); + if (!checksum) + mPUSHu(aushort); + else if (checksum > bits_in_uv) + cdouble += (NV)aushort; + else + cuv += aushort; + } + break; #else /* FALLTHROUGH */ #endif - case 'v': - case 'n': - case 'S': - while (len-- > 0) { - U16 au16; + case 'v': + case 'n': + case 'S': + while (len-- > 0) { + U16 au16; #if U16SIZE > SIZE16 - au16 = 0; + au16 = 0; #endif SHIFT16(utf8, s, strend, &au16, datumtype, needs_swap); - if (datumtype == 'n') - au16 = PerlSock_ntohs(au16); - if (datumtype == 'v') - au16 = vtohs(au16); - if (!checksum) - mPUSHu(au16); - else if (checksum > bits_in_uv) - cdouble += (NV) au16; - else - cuv += au16; - } - break; - case 'v' | TYPE_IS_SHRIEKING: - case 'n' | TYPE_IS_SHRIEKING: - while (len-- > 0) { - I16 ai16; + if (datumtype == 'n') + au16 = PerlSock_ntohs(au16); + if (datumtype == 'v') + au16 = vtohs(au16); + if (!checksum) + mPUSHu(au16); + else if (checksum > bits_in_uv) + cdouble += (NV) au16; + else + cuv += au16; + } + break; + case 'v' | TYPE_IS_SHRIEKING: + case 'n' | TYPE_IS_SHRIEKING: + while (len-- > 0) { + I16 ai16; # if U16SIZE > SIZE16 - ai16 = 0; + ai16 = 0; # endif SHIFT16(utf8, s, strend, &ai16, datumtype, needs_swap); /* There should never be any byte-swapping here. */ assert(!TYPE_ENDIANNESS(datumtype)); - if (datumtype == ('n' | TYPE_IS_SHRIEKING)) - ai16 = (I16) PerlSock_ntohs((U16) ai16); - if (datumtype == ('v' | TYPE_IS_SHRIEKING)) - ai16 = (I16) vtohs((U16) ai16); - if (!checksum) - mPUSHi(ai16); - else if (checksum > bits_in_uv) - cdouble += (NV) ai16; - else - cuv += ai16; - } - break; - case 'i': - case 'i' | TYPE_IS_SHRIEKING: - while (len-- > 0) { - int aint; + if (datumtype == ('n' | TYPE_IS_SHRIEKING)) + ai16 = (I16) PerlSock_ntohs((U16) ai16); + if (datumtype == ('v' | TYPE_IS_SHRIEKING)) + ai16 = (I16) vtohs((U16) ai16); + if (!checksum) + mPUSHi(ai16); + else if (checksum > bits_in_uv) + cdouble += (NV) ai16; + else + cuv += ai16; + } + break; + case 'i': + case 'i' | TYPE_IS_SHRIEKING: + while (len-- > 0) { + int aint; SHIFT_VAR(utf8, s, strend, aint, datumtype, needs_swap); - if (!checksum) - mPUSHi(aint); - else if (checksum > bits_in_uv) - cdouble += (NV)aint; - else - cuv += aint; - } - break; - case 'I': - case 'I' | TYPE_IS_SHRIEKING: - while (len-- > 0) { - unsigned int auint; + if (!checksum) + mPUSHi(aint); + else if (checksum > bits_in_uv) + cdouble += (NV)aint; + else + cuv += aint; + } + break; + case 'I': + case 'I' | TYPE_IS_SHRIEKING: + while (len-- > 0) { + unsigned int auint; SHIFT_VAR(utf8, s, strend, auint, datumtype, needs_swap); - if (!checksum) - mPUSHu(auint); - else if (checksum > bits_in_uv) - cdouble += (NV)auint; - else - cuv += auint; - } - break; - case 'j': - while (len-- > 0) { - IV aiv; + if (!checksum) + mPUSHu(auint); + else if (checksum > bits_in_uv) + cdouble += (NV)auint; + else + cuv += auint; + } + break; + case 'j': + while (len-- > 0) { + IV aiv; SHIFT_VAR(utf8, s, strend, aiv, datumtype, needs_swap); - if (!checksum) - mPUSHi(aiv); - else if (checksum > bits_in_uv) - cdouble += (NV)aiv; - else - cuv += aiv; - } - break; - case 'J': - while (len-- > 0) { - UV auv; + if (!checksum) + mPUSHi(aiv); + else if (checksum > bits_in_uv) + cdouble += (NV)aiv; + else + cuv += aiv; + } + break; + case 'J': + while (len-- > 0) { + UV auv; SHIFT_VAR(utf8, s, strend, auv, datumtype, needs_swap); - if (!checksum) - mPUSHu(auv); - else if (checksum > bits_in_uv) - cdouble += (NV)auv; - else - cuv += auv; - } - break; - case 'l' | TYPE_IS_SHRIEKING: + if (!checksum) + mPUSHu(auv); + else if (checksum > bits_in_uv) + cdouble += (NV)auv; + else + cuv += auv; + } + break; + case 'l' | TYPE_IS_SHRIEKING: #if LONGSIZE != SIZE32 - while (len-- > 0) { - long along; + while (len-- > 0) { + long along; SHIFT_VAR(utf8, s, strend, along, datumtype, needs_swap); - if (!checksum) - mPUSHi(along); - else if (checksum > bits_in_uv) - cdouble += (NV)along; - else - cuv += along; - } - break; + if (!checksum) + mPUSHi(along); + else if (checksum > bits_in_uv) + cdouble += (NV)along; + else + cuv += along; + } + break; #else - /* FALLTHROUGH */ + /* FALLTHROUGH */ #endif - case 'l': - while (len-- > 0) { - I32 ai32; + case 'l': + while (len-- > 0) { + I32 ai32; #if U32SIZE > SIZE32 - ai32 = 0; + ai32 = 0; #endif SHIFT32(utf8, s, strend, &ai32, datumtype, needs_swap); #if U32SIZE > SIZE32 - if (ai32 > 2147483647) ai32 -= 4294967296; + if (ai32 > 2147483647) ai32 -= 4294967296; #endif - if (!checksum) - mPUSHi(ai32); - else if (checksum > bits_in_uv) - cdouble += (NV)ai32; - else - cuv += ai32; - } - break; - case 'L' | TYPE_IS_SHRIEKING: + if (!checksum) + mPUSHi(ai32); + else if (checksum > bits_in_uv) + cdouble += (NV)ai32; + else + cuv += ai32; + } + break; + case 'L' | TYPE_IS_SHRIEKING: #if LONGSIZE != SIZE32 - while (len-- > 0) { - unsigned long aulong; + while (len-- > 0) { + unsigned long aulong; SHIFT_VAR(utf8, s, strend, aulong, datumtype, needs_swap); - if (!checksum) - mPUSHu(aulong); - else if (checksum > bits_in_uv) - cdouble += (NV)aulong; - else - cuv += aulong; - } - break; + if (!checksum) + mPUSHu(aulong); + else if (checksum > bits_in_uv) + cdouble += (NV)aulong; + else + cuv += aulong; + } + break; #else /* FALLTHROUGH */ #endif - case 'V': - case 'N': - case 'L': - while (len-- > 0) { - U32 au32; + case 'V': + case 'N': + case 'L': + while (len-- > 0) { + U32 au32; #if U32SIZE > SIZE32 - au32 = 0; + au32 = 0; #endif SHIFT32(utf8, s, strend, &au32, datumtype, needs_swap); - if (datumtype == 'N') - au32 = PerlSock_ntohl(au32); - if (datumtype == 'V') - au32 = vtohl(au32); - if (!checksum) - mPUSHu(au32); - else if (checksum > bits_in_uv) - cdouble += (NV)au32; - else - cuv += au32; - } - break; - case 'V' | TYPE_IS_SHRIEKING: - case 'N' | TYPE_IS_SHRIEKING: - while (len-- > 0) { - I32 ai32; + if (datumtype == 'N') + au32 = PerlSock_ntohl(au32); + if (datumtype == 'V') + au32 = vtohl(au32); + if (!checksum) + mPUSHu(au32); + else if (checksum > bits_in_uv) + cdouble += (NV)au32; + else + cuv += au32; + } + break; + case 'V' | TYPE_IS_SHRIEKING: + case 'N' | TYPE_IS_SHRIEKING: + while (len-- > 0) { + I32 ai32; #if U32SIZE > SIZE32 - ai32 = 0; + ai32 = 0; #endif SHIFT32(utf8, s, strend, &ai32, datumtype, needs_swap); /* There should never be any byte swapping here. */ assert(!TYPE_ENDIANNESS(datumtype)); - if (datumtype == ('N' | TYPE_IS_SHRIEKING)) - ai32 = (I32)PerlSock_ntohl((U32)ai32); - if (datumtype == ('V' | TYPE_IS_SHRIEKING)) - ai32 = (I32)vtohl((U32)ai32); - if (!checksum) - mPUSHi(ai32); - else if (checksum > bits_in_uv) - cdouble += (NV)ai32; - else - cuv += ai32; - } - break; - case 'p': - while (len-- > 0) { - const char *aptr; + if (datumtype == ('N' | TYPE_IS_SHRIEKING)) + ai32 = (I32)PerlSock_ntohl((U32)ai32); + if (datumtype == ('V' | TYPE_IS_SHRIEKING)) + ai32 = (I32)vtohl((U32)ai32); + if (!checksum) + mPUSHi(ai32); + else if (checksum > bits_in_uv) + cdouble += (NV)ai32; + else + cuv += ai32; + } + break; + case 'p': + while (len-- > 0) { + const char *aptr; SHIFT_VAR(utf8, s, strend, aptr, datumtype, needs_swap); - /* newSVpv generates undef if aptr is NULL */ - mPUSHs(newSVpv(aptr, 0)); - } - break; - case 'w': - { - UV auv = 0; - size_t bytes = 0; - - while (len > 0 && s < strend) { - U8 ch; - ch = SHIFT_BYTE(utf8, s, strend, datumtype); - auv = (auv << 7) | (ch & 0x7f); + /* newSVpv generates undef if aptr is NULL */ + mPUSHs(newSVpv(aptr, 0)); + } + break; + case 'w': + { + UV auv = 0; + size_t bytes = 0; + + while (len > 0 && s < strend) { + U8 ch; + ch = SHIFT_BYTE(utf8, s, strend, datumtype); + auv = (auv << 7) | (ch & 0x7f); /* UTF8_IS_XXXXX not right here because this is a BER, not * UTF-8 format - using constant 0x80 */ - if (ch < 0x80) { - bytes = 0; - mPUSHu(auv); - len--; - auv = 0; - continue; - } - if (++bytes >= sizeof(UV)) { /* promote to string */ - const char *t; - - sv = Perl_newSVpvf(aTHX_ "%.*" UVuf, + if (ch < 0x80) { + bytes = 0; + mPUSHu(auv); + len--; + auv = 0; + continue; + } + if (++bytes >= sizeof(UV)) { /* promote to string */ + const char *t; + + sv = Perl_newSVpvf(aTHX_ "%.*" UVuf, (int)TYPE_DIGITS(UV), auv); - while (s < strend) { - ch = SHIFT_BYTE(utf8, s, strend, datumtype); - sv = mul128(sv, (U8)(ch & 0x7f)); - if (!(ch & 0x80)) { - bytes = 0; - break; - } - } - t = SvPV_nolen_const(sv); - while (*t == '0') - t++; - sv_chop(sv, t); - mPUSHs(sv); - len--; - auv = 0; - } - } - if ((s >= strend) && bytes) - Perl_croak(aTHX_ "Unterminated compressed integer in unpack"); - } - break; - case 'P': - if (symptr->howlen == e_star) - Perl_croak(aTHX_ "'P' must have an explicit size in unpack"); - EXTEND(SP, 1); - if (s + sizeof(char*) <= strend) { - char *aptr; + while (s < strend) { + ch = SHIFT_BYTE(utf8, s, strend, datumtype); + sv = mul128(sv, (U8)(ch & 0x7f)); + if (!(ch & 0x80)) { + bytes = 0; + break; + } + } + t = SvPV_nolen_const(sv); + while (*t == '0') + t++; + sv_chop(sv, t); + mPUSHs(sv); + len--; + auv = 0; + } + } + if ((s >= strend) && bytes) + Perl_croak(aTHX_ "Unterminated compressed integer in unpack"); + } + break; + case 'P': + if (symptr->howlen == e_star) + Perl_croak(aTHX_ "'P' must have an explicit size in unpack"); + EXTEND(SP, 1); + if (s + sizeof(char*) <= strend) { + char *aptr; SHIFT_VAR(utf8, s, strend, aptr, datumtype, needs_swap); - /* newSVpvn generates undef if aptr is NULL */ - PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP)); - } - break; + /* newSVpvn generates undef if aptr is NULL */ + PUSHs(newSVpvn_flags(aptr, len, SVs_TEMP)); + } + break; #if defined(HAS_QUAD) && IVSIZE >= 8 - case 'q': - while (len-- > 0) { - Quad_t aquad; + case 'q': + while (len-- > 0) { + Quad_t aquad; SHIFT_VAR(utf8, s, strend, aquad, datumtype, needs_swap); - if (!checksum) + if (!checksum) mPUSHs(newSViv((IV)aquad)); - else if (checksum > bits_in_uv) - cdouble += (NV)aquad; - else - cuv += aquad; - } - break; - case 'Q': - while (len-- > 0) { - Uquad_t auquad; + else if (checksum > bits_in_uv) + cdouble += (NV)aquad; + else + cuv += aquad; + } + break; + case 'Q': + while (len-- > 0) { + Uquad_t auquad; SHIFT_VAR(utf8, s, strend, auquad, datumtype, needs_swap); - if (!checksum) - mPUSHs(newSVuv((UV)auquad)); - else if (checksum > bits_in_uv) - cdouble += (NV)auquad; - else - cuv += auquad; - } - break; + if (!checksum) + mPUSHs(newSVuv((UV)auquad)); + else if (checksum > bits_in_uv) + cdouble += (NV)auquad; + else + cuv += auquad; + } + break; #endif - /* float and double added gnb@melba.bby.oz.au 22/11/89 */ - case 'f': - while (len-- > 0) { - float afloat; + /* float and double added gnb@melba.bby.oz.au 22/11/89 */ + case 'f': + while (len-- > 0) { + float afloat; SHIFT_VAR(utf8, s, strend, afloat, datumtype, needs_swap); - if (!checksum) - mPUSHn(afloat); - else - cdouble += afloat; - } - break; - case 'd': - while (len-- > 0) { - double adouble; + if (!checksum) + mPUSHn(afloat); + else + cdouble += afloat; + } + break; + case 'd': + while (len-- > 0) { + double adouble; SHIFT_VAR(utf8, s, strend, adouble, datumtype, needs_swap); - if (!checksum) - mPUSHn(adouble); - else - cdouble += adouble; - } - break; - case 'F': - while (len-- > 0) { - NV_bytes anv; + if (!checksum) + mPUSHn(adouble); + else + cdouble += adouble; + } + break; + case 'F': + while (len-- > 0) { + NV_bytes anv; SHIFT_BYTES(utf8, s, strend, anv.bytes, sizeof(anv.bytes), datumtype, needs_swap); - if (!checksum) - mPUSHn(anv.nv); - else - cdouble += anv.nv; - } - break; + if (!checksum) + mPUSHn(anv.nv); + else + cdouble += anv.nv; + } + break; #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) - case 'D': - while (len-- > 0) { - ld_bytes aldouble; + case 'D': + while (len-- > 0) { + ld_bytes aldouble; SHIFT_BYTES(utf8, s, strend, aldouble.bytes, sizeof(aldouble.bytes), datumtype, needs_swap); /* The most common long double format, the x86 80-bit @@ -1714,22 +1714,22 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c * Note that trying to unpack 'long doubles' of 'long * doubles' packed in another system is in the general * case doomed without having more detail. */ - if (!checksum) - mPUSHn(aldouble.ld); - else - cdouble += aldouble.ld; - } - break; + if (!checksum) + mPUSHn(aldouble.ld); + else + cdouble += aldouble.ld; + } + break; #endif - case 'u': - if (!checksum) { + case 'u': + if (!checksum) { const STRLEN l = (STRLEN) (strend - s) * 3 / 4; - sv = sv_2mortal(newSV(l)); - if (l) { + sv = sv_2mortal(newSV(l)); + if (l) { SvPOK_on(sv); *SvEND(sv) = '\0'; } - } + } /* Note that all legal uuencoded strings are ASCII printables, so * have the same representation under UTF-8 vs not. This means we @@ -1772,25 +1772,25 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c if (s + 1 < strend && s[1] == '\n') s += 2; } - if (!checksum) - XPUSHs(sv); - break; - } /* End of switch */ + if (!checksum) + XPUSHs(sv); + break; + } /* End of switch */ - if (checksum) { - if (memCHRs("fFdD", TYPE_NO_MODIFIERS(datumtype)) || - (checksum > bits_in_uv && - memCHRs("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) { - NV trouble, anv; + if (checksum) { + if (memCHRs("fFdD", TYPE_NO_MODIFIERS(datumtype)) || + (checksum > bits_in_uv && + memCHRs("cCsSiIlLnNUWvVqQjJ", TYPE_NO_MODIFIERS(datumtype))) ) { + NV trouble, anv; anv = (NV) (1 << (checksum & 15)); - while (checksum >= 16) { - checksum -= 16; - anv *= 65536.0; - } - while (cdouble < 0.0) - cdouble += anv; - cdouble = Perl_modf(cdouble / anv, &trouble); + while (checksum >= 16) { + checksum -= 16; + anv *= 65536.0; + } + while (cdouble < 0.0) + cdouble += anv; + cdouble = Perl_modf(cdouble / anv, &trouble); #ifdef LONGDOUBLE_DOUBLEDOUBLE /* Workaround for powerpc doubledouble modfl bug: * close to 1.0L and -1.0L cdouble is 0, and trouble @@ -1802,45 +1802,45 @@ S_unpack_rec(pTHX_ tempsym_t* symptr, const char *s, const char *strbeg, const c } #endif cdouble *= anv; - sv = newSVnv(cdouble); - } - else { - if (checksum < bits_in_uv) { - UV mask = nBIT_MASK(checksum); - cuv &= mask; - } - sv = newSVuv(cuv); - } - mXPUSHs(sv); - checksum = 0; - } + sv = newSVnv(cdouble); + } + else { + if (checksum < bits_in_uv) { + UV mask = nBIT_MASK(checksum); + cuv &= mask; + } + sv = newSVuv(cuv); + } + mXPUSHs(sv); + checksum = 0; + } if (symptr->flags & FLAG_SLASH){ if (SP - PL_stack_base - start_sp_offset <= 0) - break; + break; if( next_symbol(symptr) ){ if( symptr->howlen == e_number ) - Perl_croak(aTHX_ "Count after length/code in unpack" ); + Perl_croak(aTHX_ "Count after length/code in unpack" ); if( beyond ){ - /* ...end of char buffer then no decent length available */ - Perl_croak(aTHX_ "length/code after end of string in unpack" ); + /* ...end of char buffer then no decent length available */ + Perl_croak(aTHX_ "length/code after end of string in unpack" ); } else { - /* take top of stack (hope it's numeric) */ + /* take top of stack (hope it's numeric) */ len = POPi; if( len < 0 ) Perl_croak(aTHX_ "Negative '/' count in unpack" ); } } else { - Perl_croak(aTHX_ "Code missing after '/' in unpack" ); + Perl_croak(aTHX_ "Code missing after '/' in unpack" ); } datumtype = symptr->code; explicit_length = FALSE; - goto redo_switch; + goto redo_switch; } } if (new_s) - *new_s = s; + *new_s = s; PUTBACK; return SP - PL_stack_base - start_sp_offset; } @@ -1860,8 +1860,8 @@ PP(pp_unpack) PUTBACK; cnt = unpackstring(pat, patend, s, strend, - ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0) - | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0)); + ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0) + | (DO_UTF8(right) ? FLAG_DO_UTF8 : 0)); SPAGAIN; if ( !cnt && gimme == G_SCALAR ) @@ -1874,19 +1874,19 @@ doencodes(U8 *h, const U8 *s, SSize_t len) { *h++ = PL_uuemap[len]; while (len > 2) { - *h++ = PL_uuemap[(077 & (s[0] >> 2))]; - *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))]; - *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; - *h++ = PL_uuemap[(077 & (s[2] & 077))]; - s += 3; - len -= 3; + *h++ = PL_uuemap[(077 & (s[0] >> 2))]; + *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((s[1] >> 4) & 017)))]; + *h++ = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; + *h++ = PL_uuemap[(077 & (s[2] & 077))]; + s += 3; + len -= 3; } if (len > 0) { const U8 r = (len > 1 ? s[1] : '\0'); - *h++ = PL_uuemap[(077 & (s[0] >> 2))]; - *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))]; - *h++ = PL_uuemap[(077 & ((r << 2) & 074))]; - *h++ = PL_uuemap[0]; + *h++ = PL_uuemap[(077 & (s[0] >> 2))]; + *h++ = PL_uuemap[(077 & (((s[0] << 4) & 060) | ((r >> 4) & 017)))]; + *h++ = PL_uuemap[(077 & ((r << 2) & 074))]; + *h++ = PL_uuemap[0]; } *h++ = '\n'; return h; @@ -1909,8 +1909,8 @@ S_is_an_int(pTHX_ const char *s, STRLEN l) break; case '+': if (!skip) { - SvREFCNT_dec(result); - return (NULL); + SvREFCNT_dec(result); + return (NULL); } break; case '0': @@ -1925,7 +1925,7 @@ S_is_an_int(pTHX_ const char *s, STRLEN l) case '9': skip = 0; if (!ignore) { - *(out++) = *s; + *(out++) = *s; } break; case '.': @@ -1955,13 +1955,13 @@ S_div128(pTHX_ SV *pnum, bool *done) *done = 1; while (*t) { - const int i = m * 10 + (*t - '0'); - const int r = (i >> 7); /* r < 10 */ - m = i & 0x7F; - if (r) { - *done = 0; - } - *(t++) = '0' + r; + const int i = m * 10 + (*t - '0'); + const int r = (i >> 7); /* r < 10 */ + m = i & 0x7F; + if (r) { + *done = 0; + } + *(t++) = '0' + r; } *(t++) = '\0'; SvCUR_set(pnum, (STRLEN) (t - s)); @@ -1989,7 +1989,7 @@ Perl_packlist(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, Also make sure any UTF8 flag is loaded */ SvPV_force_nolen(cat); if (DO_UTF8(cat)) - sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8; + sym.flags |= FLAG_PARSE_UTF8 | FLAG_DO_UTF8; (void)pack_rec( cat, &sym, beglist, endlist ); } @@ -2007,11 +2007,11 @@ marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { from_start = SvPVX_const(sv); from_end = from_start + SvCUR(sv); for (from_ptr = from_start; from_ptr < from_end; from_ptr++) - if (!NATIVE_BYTE_IS_INVARIANT(*from_ptr)) break; + if (!NATIVE_BYTE_IS_INVARIANT(*from_ptr)) break; if (from_ptr == from_end) { - /* Simple case: no character needs to be changed */ - SvUTF8_on(sv); - return; + /* Simple case: no character needs to be changed */ + SvUTF8_on(sv); + return; } len = (from_end-from_ptr)*UTF8_EXPAND+(from_ptr-from_start)+1; @@ -2021,38 +2021,38 @@ marked_upgrade(pTHX_ SV *sv, tempsym_t *sym_ptr) { Newx(marks, sym_ptr->level+2, const char *); for (group=sym_ptr; group; group = group->previous) - marks[group->level] = from_start + group->strbeg; + marks[group->level] = from_start + group->strbeg; marks[sym_ptr->level+1] = from_end+1; for (m = marks; *m < from_ptr; m++) - *m = to_start + (*m-from_start); + *m = to_start + (*m-from_start); for (;from_ptr < from_end; from_ptr++) { - while (*m == from_ptr) *m++ = to_ptr; - to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr); + while (*m == from_ptr) *m++ = to_ptr; + to_ptr = (char *) uvchr_to_utf8((U8 *) to_ptr, *(U8 *) from_ptr); } *to_ptr = 0; while (*m == from_ptr) *m++ = to_ptr; if (m != marks + sym_ptr->level+1) { - Safefree(marks); - Safefree(to_start); - Perl_croak(aTHX_ "panic: marks beyond string end, m=%p, marks=%p, " - "level=%d", m, marks, sym_ptr->level); + Safefree(marks); + Safefree(to_start); + Perl_croak(aTHX_ "panic: marks beyond string end, m=%p, marks=%p, " + "level=%d", m, marks, sym_ptr->level); } for (group=sym_ptr; group; group = group->previous) - group->strbeg = marks[group->level] - to_start; + group->strbeg = marks[group->level] - to_start; Safefree(marks); if (SvOOK(sv)) { - if (SvIVX(sv)) { - SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); - from_start -= SvIVX(sv); - SvIV_set(sv, 0); - } - SvFLAGS(sv) &= ~SVf_OOK; + if (SvIVX(sv)) { + SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); + from_start -= SvIVX(sv); + SvIV_set(sv, 0); + } + SvFLAGS(sv) &= ~SVf_OOK; } if (SvLEN(sv) != 0) - Safefree(from_start); + Safefree(from_start); SvPV_set(sv, to_start); SvCUR_set(sv, to_ptr - to_start); SvLEN_set(sv, len); @@ -2081,22 +2081,22 @@ S_sv_check_infnan(pTHX_ SV *sv, I32 datumtype) { SvGETMAGIC(sv); if (UNLIKELY(SvAMAGIC(sv))) - sv = sv_2num(sv); + sv = sv_2num(sv); if (UNLIKELY(isinfnansv(sv))) { - const I32 c = TYPE_NO_MODIFIERS(datumtype); - const NV nv = SvNV_nomg(sv); - if (c == 'w') - Perl_croak(aTHX_ "Cannot compress %" NVgf " in pack", nv); - else - Perl_croak(aTHX_ "Cannot pack %" NVgf " with '%c'", nv, (int) c); + const I32 c = TYPE_NO_MODIFIERS(datumtype); + const NV nv = SvNV_nomg(sv); + if (c == 'w') + Perl_croak(aTHX_ "Cannot compress %" NVgf " in pack", nv); + else + Perl_croak(aTHX_ "Cannot pack %" NVgf " with '%c'", nv, (int) c); } return sv; } #define SvIV_no_inf(sv,d) \ - ((sv) = S_sv_check_infnan(aTHX_ sv,d), SvIV_nomg(sv)) + ((sv) = S_sv_check_infnan(aTHX_ sv,d), SvIV_nomg(sv)) #define SvUV_no_inf(sv,d) \ - ((sv) = S_sv_check_infnan(aTHX_ sv,d), SvUV_nomg(sv)) + ((sv) = S_sv_check_infnan(aTHX_ sv,d), SvUV_nomg(sv)) STATIC SV ** @@ -2112,640 +2112,640 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) PERL_ARGS_ASSERT_PACK_REC; if (symptr->level == 0 && found && symptr->code == 'U') { - marked_upgrade(aTHX_ cat, symptr); - symptr->flags |= FLAG_DO_UTF8; - utf8 = 0; + marked_upgrade(aTHX_ cat, symptr); + symptr->flags |= FLAG_DO_UTF8; + utf8 = 0; } symptr->strbeg = SvCUR(cat); while (found) { - SV *fromstr; - STRLEN fromlen; - SSize_t len; - SV *lengthcode = NULL; + SV *fromstr; + STRLEN fromlen; + SSize_t len; + SV *lengthcode = NULL; I32 datumtype = symptr->code; howlen_t howlen = symptr->howlen; - char *start = SvPVX(cat); - char *cur = start + SvCUR(cat); + char *start = SvPVX(cat); + char *cur = start + SvCUR(cat); bool needs_swap; #define NEXTFROM (lengthcode ? lengthcode : items > 0 ? (--items, *beglist++) : &PL_sv_no) #define PEEKFROM (lengthcode ? lengthcode : items > 0 ? *beglist : &PL_sv_no) switch (howlen) { - case e_star: - len = memCHRs("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? - 0 : items; - break; - default: - /* e_no_len and e_number */ - len = symptr->length; - break; + case e_star: + len = memCHRs("@Xxu", TYPE_NO_MODIFIERS(datumtype)) ? + 0 : items; + break; + default: + /* e_no_len and e_number */ + len = symptr->length; + break; } - if (len) { - packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)]; + if (len) { + packprops_t props = packprops[TYPE_NO_ENDIANNESS(datumtype)]; - if (props && !(props & PACK_SIZE_UNPREDICTABLE)) { - /* We can process this letter. */ - STRLEN size = props & PACK_SIZE_MASK; - GROWING2(utf8, cat, start, cur, size, (STRLEN)len); - } + if (props && !(props & PACK_SIZE_UNPREDICTABLE)) { + /* We can process this letter. */ + STRLEN size = props & PACK_SIZE_MASK; + GROWING2(utf8, cat, start, cur, size, (STRLEN)len); + } } /* Look ahead for next symbol. Do we have code/code? */ lookahead = *symptr; found = next_symbol(&lookahead); - if (symptr->flags & FLAG_SLASH) { - IV count; - if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack"); - if (memCHRs("aAZ", lookahead.code)) { - if (lookahead.howlen == e_number) count = lookahead.length; - else { - if (items > 0) { - count = sv_len_utf8(*beglist); - } - else count = 0; - if (lookahead.code == 'Z') count++; - } - } else { - if (lookahead.howlen == e_number && lookahead.length < items) - count = lookahead.length; - else count = items; - } - lookahead.howlen = e_number; - lookahead.length = count; - lengthcode = sv_2mortal(newSViv(count)); - } + if (symptr->flags & FLAG_SLASH) { + IV count; + if (!found) Perl_croak(aTHX_ "Code missing after '/' in pack"); + if (memCHRs("aAZ", lookahead.code)) { + if (lookahead.howlen == e_number) count = lookahead.length; + else { + if (items > 0) { + count = sv_len_utf8(*beglist); + } + else count = 0; + if (lookahead.code == 'Z') count++; + } + } else { + if (lookahead.howlen == e_number && lookahead.length < items) + count = lookahead.length; + else count = items; + } + lookahead.howlen = e_number; + lookahead.length = count; + lengthcode = sv_2mortal(newSViv(count)); + } needs_swap = NEEDS_SWAP(datumtype); - /* Code inside the switch must take care to properly update - cat (CUR length and '\0' termination) if it updated *cur and - doesn't simply leave using break */ - switch (TYPE_NO_ENDIANNESS(datumtype)) { - default: - Perl_croak(aTHX_ "Invalid type '%c' in pack", - (int) TYPE_NO_MODIFIERS(datumtype)); - case '%': - Perl_croak(aTHX_ "'%%' may not be used in pack"); - - case '.' | TYPE_IS_SHRIEKING: - case '.': - if (howlen == e_star) from = start; - else if (len == 0) from = cur; - else { - tempsym_t *group = symptr; - - while (--len && group) group = group->previous; - from = group ? start + group->strbeg : start; - } - fromstr = NEXTFROM; - len = SvIV_no_inf(fromstr, datumtype); - goto resize; - case '@' | TYPE_IS_SHRIEKING: - case '@': - from = start + symptr->strbeg; - resize: - if (utf8 && !(datumtype & TYPE_IS_SHRIEKING)) - if (len >= 0) { - while (len && from < cur) { - from += UTF8SKIP(from); - len--; - } - if (from > cur) - Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); - if (len) { - /* Here we know from == cur */ - grow: - GROWING(0, cat, start, cur, len); - Zero(cur, len, char); - cur += len; - } else if (from < cur) { - len = cur - from; - goto shrink; - } else goto no_change; - } else { - cur = from; - len = -len; - goto utf8_shrink; - } - else { - len -= cur - from; - if (len > 0) goto grow; - if (len == 0) goto no_change; - len = -len; - goto shrink; - } - break; - - case '(': { + /* Code inside the switch must take care to properly update + cat (CUR length and '\0' termination) if it updated *cur and + doesn't simply leave using break */ + switch (TYPE_NO_ENDIANNESS(datumtype)) { + default: + Perl_croak(aTHX_ "Invalid type '%c' in pack", + (int) TYPE_NO_MODIFIERS(datumtype)); + case '%': + Perl_croak(aTHX_ "'%%' may not be used in pack"); + + case '.' | TYPE_IS_SHRIEKING: + case '.': + if (howlen == e_star) from = start; + else if (len == 0) from = cur; + else { + tempsym_t *group = symptr; + + while (--len && group) group = group->previous; + from = group ? start + group->strbeg : start; + } + fromstr = NEXTFROM; + len = SvIV_no_inf(fromstr, datumtype); + goto resize; + case '@' | TYPE_IS_SHRIEKING: + case '@': + from = start + symptr->strbeg; + resize: + if (utf8 && !(datumtype & TYPE_IS_SHRIEKING)) + if (len >= 0) { + while (len && from < cur) { + from += UTF8SKIP(from); + len--; + } + if (from > cur) + Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); + if (len) { + /* Here we know from == cur */ + grow: + GROWING(0, cat, start, cur, len); + Zero(cur, len, char); + cur += len; + } else if (from < cur) { + len = cur - from; + goto shrink; + } else goto no_change; + } else { + cur = from; + len = -len; + goto utf8_shrink; + } + else { + len -= cur - from; + if (len > 0) goto grow; + if (len == 0) goto no_change; + len = -len; + goto shrink; + } + break; + + case '(': { tempsym_t savsym = *symptr; - U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags); - symptr->flags |= group_modifiers; + U32 group_modifiers = TYPE_MODIFIERS(datumtype & ~symptr->flags); + symptr->flags |= group_modifiers; symptr->patend = savsym.grpend; symptr->level++; - symptr->previous = &lookahead; - while (len--) { - U32 was_utf8; - if (utf8) symptr->flags |= FLAG_PARSE_UTF8; - else symptr->flags &= ~FLAG_PARSE_UTF8; - was_utf8 = SvUTF8(cat); - symptr->patptr = savsym.grpbeg; - beglist = pack_rec(cat, symptr, beglist, endlist); - if (SvUTF8(cat) != was_utf8) - /* This had better be an upgrade while in utf8==0 mode */ - utf8 = 1; - - if (savsym.howlen == e_star && beglist == endlist) - break; /* No way to continue */ - } - items = endlist - beglist; - lookahead.flags = symptr->flags & ~group_modifiers; - goto no_change; - } - case 'X' | TYPE_IS_SHRIEKING: - if (!len) /* Avoid division by 0 */ - len = 1; - if (utf8) { - char *hop, *last; - SSize_t l = len; - hop = last = start; - while (hop < cur) { - hop += UTF8SKIP(hop); - if (--l == 0) { - last = hop; - l = len; - } - } - if (last > cur) - Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); - cur = last; - break; - } - len = (cur-start) % len; - /* FALLTHROUGH */ - case 'X': - if (utf8) { - if (len < 1) goto no_change; - utf8_shrink: - while (len > 0) { - if (cur <= start) - Perl_croak(aTHX_ "'%c' outside of string in pack", - (int) TYPE_NO_MODIFIERS(datumtype)); - while (--cur, UTF8_IS_CONTINUATION(*cur)) { - if (cur <= start) - Perl_croak(aTHX_ "'%c' outside of string in pack", - (int) TYPE_NO_MODIFIERS(datumtype)); - } - len--; - } - } else { - shrink: - if (cur - start < len) - Perl_croak(aTHX_ "'%c' outside of string in pack", - (int) TYPE_NO_MODIFIERS(datumtype)); - cur -= len; - } - if (cur < start+symptr->strbeg) { - /* Make sure group starts don't point into the void */ - tempsym_t *group; - const STRLEN length = cur-start; - for (group = symptr; - group && length < group->strbeg; - group = group->previous) group->strbeg = length; - lookahead.strbeg = length; - } - break; - case 'x' | TYPE_IS_SHRIEKING: { - SSize_t ai32; - if (!len) /* Avoid division by 0 */ - len = 1; - if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len; - else ai32 = (cur - start) % len; - if (ai32 == 0) goto no_change; - len -= ai32; - } - /* FALLTHROUGH */ - case 'x': - goto grow; - case 'A': - case 'Z': - case 'a': { - const char *aptr; - - fromstr = NEXTFROM; - aptr = SvPV_const(fromstr, fromlen); - if (DO_UTF8(fromstr)) { + symptr->previous = &lookahead; + while (len--) { + U32 was_utf8; + if (utf8) symptr->flags |= FLAG_PARSE_UTF8; + else symptr->flags &= ~FLAG_PARSE_UTF8; + was_utf8 = SvUTF8(cat); + symptr->patptr = savsym.grpbeg; + beglist = pack_rec(cat, symptr, beglist, endlist); + if (SvUTF8(cat) != was_utf8) + /* This had better be an upgrade while in utf8==0 mode */ + utf8 = 1; + + if (savsym.howlen == e_star && beglist == endlist) + break; /* No way to continue */ + } + items = endlist - beglist; + lookahead.flags = symptr->flags & ~group_modifiers; + goto no_change; + } + case 'X' | TYPE_IS_SHRIEKING: + if (!len) /* Avoid division by 0 */ + len = 1; + if (utf8) { + char *hop, *last; + SSize_t l = len; + hop = last = start; + while (hop < cur) { + hop += UTF8SKIP(hop); + if (--l == 0) { + last = hop; + l = len; + } + } + if (last > cur) + Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); + cur = last; + break; + } + len = (cur-start) % len; + /* FALLTHROUGH */ + case 'X': + if (utf8) { + if (len < 1) goto no_change; + utf8_shrink: + while (len > 0) { + if (cur <= start) + Perl_croak(aTHX_ "'%c' outside of string in pack", + (int) TYPE_NO_MODIFIERS(datumtype)); + while (--cur, UTF8_IS_CONTINUATION(*cur)) { + if (cur <= start) + Perl_croak(aTHX_ "'%c' outside of string in pack", + (int) TYPE_NO_MODIFIERS(datumtype)); + } + len--; + } + } else { + shrink: + if (cur - start < len) + Perl_croak(aTHX_ "'%c' outside of string in pack", + (int) TYPE_NO_MODIFIERS(datumtype)); + cur -= len; + } + if (cur < start+symptr->strbeg) { + /* Make sure group starts don't point into the void */ + tempsym_t *group; + const STRLEN length = cur-start; + for (group = symptr; + group && length < group->strbeg; + group = group->previous) group->strbeg = length; + lookahead.strbeg = length; + } + break; + case 'x' | TYPE_IS_SHRIEKING: { + SSize_t ai32; + if (!len) /* Avoid division by 0 */ + len = 1; + if (utf8) ai32 = utf8_length((U8 *) start, (U8 *) cur) % len; + else ai32 = (cur - start) % len; + if (ai32 == 0) goto no_change; + len -= ai32; + } + /* FALLTHROUGH */ + case 'x': + goto grow; + case 'A': + case 'Z': + case 'a': { + const char *aptr; + + fromstr = NEXTFROM; + aptr = SvPV_const(fromstr, fromlen); + if (DO_UTF8(fromstr)) { const char *end, *s; - if (!utf8 && !SvUTF8(cat)) { - marked_upgrade(aTHX_ cat, symptr); - lookahead.flags |= FLAG_DO_UTF8; - lookahead.strbeg = symptr->strbeg; - utf8 = 1; - start = SvPVX(cat); - cur = start + SvCUR(cat); - } - if (howlen == e_star) { - if (utf8) goto string_copy; - len = fromlen+1; - } - s = aptr; - end = aptr + fromlen; - fromlen = datumtype == 'Z' ? len-1 : len; - while ((SSize_t) fromlen > 0 && s < end) { - s += UTF8SKIP(s); - fromlen--; - } - if (s > end) - Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); - if (utf8) { - len = fromlen; - if (datumtype == 'Z') len++; - fromlen = s-aptr; - len += fromlen; - - goto string_copy; - } - fromlen = len - fromlen; - if (datumtype == 'Z') fromlen--; - if (howlen == e_star) { - len = fromlen; - if (datumtype == 'Z') len++; - } - GROWING(0, cat, start, cur, len); - if (!S_utf8_to_bytes(aTHX_ &aptr, end, cur, fromlen, - datumtype | TYPE_IS_PACK)) - Perl_croak(aTHX_ "panic: predicted utf8 length not available, " - "for '%c', aptr=%p end=%p cur=%p, fromlen=%zu", - (int)datumtype, aptr, end, cur, fromlen); - cur += fromlen; - len -= fromlen; - } else if (utf8) { - if (howlen == e_star) { - len = fromlen; - if (datumtype == 'Z') len++; - } - if (len <= (SSize_t) fromlen) { - fromlen = len; - if (datumtype == 'Z' && fromlen > 0) fromlen--; - } - /* assumes a byte expands to at most UTF8_EXPAND bytes on - upgrade, so: - expected_length <= from_len*UTF8_EXPAND + (len-from_len) */ - GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len); - len -= fromlen; - while (fromlen > 0) { - cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr); - aptr++; - fromlen--; - } - } else { - string_copy: - if (howlen == e_star) { - len = fromlen; - if (datumtype == 'Z') len++; - } - if (len <= (SSize_t) fromlen) { - fromlen = len; - if (datumtype == 'Z' && fromlen > 0) fromlen--; - } - GROWING(0, cat, start, cur, len); - Copy(aptr, cur, fromlen, char); - cur += fromlen; - len -= fromlen; - } - memset(cur, datumtype == 'A' ? ' ' : '\0', len); - cur += len; - SvTAINT(cat); - break; - } - case 'B': - case 'b': { - const char *str, *end; - SSize_t l, field_len; - U8 bits; - bool utf8_source; - U32 utf8_flags; - - fromstr = NEXTFROM; - str = SvPV_const(fromstr, fromlen); - end = str + fromlen; - if (DO_UTF8(fromstr)) { - utf8_source = TRUE; - utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY; - } else { - utf8_source = FALSE; - utf8_flags = 0; /* Unused, but keep compilers happy */ - } - if (howlen == e_star) len = fromlen; - field_len = (len+7)/8; - GROWING(utf8, cat, start, cur, field_len); - if (len > (SSize_t)fromlen) len = fromlen; - bits = 0; - l = 0; - if (datumtype == 'B') - while (l++ < len) { - if (utf8_source) { - UV val = 0; - NEXT_UNI_VAL(val, cur, str, end, utf8_flags); - bits |= val & 1; - } else bits |= *str++ & 1; - if (l & 7) bits <<= 1; - else { - PUSH_BYTE(utf8, cur, bits); - bits = 0; - } - } - else - /* datumtype == 'b' */ - while (l++ < len) { - if (utf8_source) { - UV val = 0; - NEXT_UNI_VAL(val, cur, str, end, utf8_flags); - if (val & 1) bits |= 0x80; - } else if (*str++ & 1) - bits |= 0x80; - if (l & 7) bits >>= 1; - else { - PUSH_BYTE(utf8, cur, bits); - bits = 0; - } - } - l--; - if (l & 7) { - if (datumtype == 'B') - bits <<= 7 - (l & 7); - else - bits >>= 7 - (l & 7); - PUSH_BYTE(utf8, cur, bits); - l += 7; - } - /* Determine how many chars are left in the requested field */ - l /= 8; - if (howlen == e_star) field_len = 0; - else field_len -= l; - Zero(cur, field_len, char); - cur += field_len; - break; - } - case 'H': - case 'h': { - const char *str, *end; - SSize_t l, field_len; - U8 bits; - bool utf8_source; - U32 utf8_flags; - - fromstr = NEXTFROM; - str = SvPV_const(fromstr, fromlen); - end = str + fromlen; - if (DO_UTF8(fromstr)) { - utf8_source = TRUE; - utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY; - } else { - utf8_source = FALSE; - utf8_flags = 0; /* Unused, but keep compilers happy */ - } - if (howlen == e_star) len = fromlen; - field_len = (len+1)/2; - GROWING(utf8, cat, start, cur, field_len); - if (!utf8_source && len > (SSize_t)fromlen) len = fromlen; - bits = 0; - l = 0; - if (datumtype == 'H') - while (l++ < len) { - if (utf8_source) { - UV val = 0; - NEXT_UNI_VAL(val, cur, str, end, utf8_flags); - if (val < 256 && isALPHA(val)) - bits |= (val + 9) & 0xf; - else - bits |= val & 0xf; - } else if (isALPHA(*str)) - bits |= (*str++ + 9) & 0xf; - else - bits |= *str++ & 0xf; - if (l & 1) bits <<= 4; - else { - PUSH_BYTE(utf8, cur, bits); - bits = 0; - } - } - else - while (l++ < len) { - if (utf8_source) { - UV val = 0; - NEXT_UNI_VAL(val, cur, str, end, utf8_flags); - if (val < 256 && isALPHA(val)) - bits |= ((val + 9) & 0xf) << 4; - else - bits |= (val & 0xf) << 4; - } else if (isALPHA(*str)) - bits |= ((*str++ + 9) & 0xf) << 4; - else - bits |= (*str++ & 0xf) << 4; - if (l & 1) bits >>= 4; - else { - PUSH_BYTE(utf8, cur, bits); - bits = 0; - } - } - l--; - if (l & 1) { - PUSH_BYTE(utf8, cur, bits); - l++; - } - /* Determine how many chars are left in the requested field */ - l /= 2; - if (howlen == e_star) field_len = 0; - else field_len -= l; - Zero(cur, field_len, char); - cur += field_len; - break; - } - case 'c': - while (len-- > 0) { - IV aiv; - fromstr = NEXTFROM; + if (!utf8 && !SvUTF8(cat)) { + marked_upgrade(aTHX_ cat, symptr); + lookahead.flags |= FLAG_DO_UTF8; + lookahead.strbeg = symptr->strbeg; + utf8 = 1; + start = SvPVX(cat); + cur = start + SvCUR(cat); + } + if (howlen == e_star) { + if (utf8) goto string_copy; + len = fromlen+1; + } + s = aptr; + end = aptr + fromlen; + fromlen = datumtype == 'Z' ? len-1 : len; + while ((SSize_t) fromlen > 0 && s < end) { + s += UTF8SKIP(s); + fromlen--; + } + if (s > end) + Perl_croak(aTHX_ "Malformed UTF-8 string in pack"); + if (utf8) { + len = fromlen; + if (datumtype == 'Z') len++; + fromlen = s-aptr; + len += fromlen; + + goto string_copy; + } + fromlen = len - fromlen; + if (datumtype == 'Z') fromlen--; + if (howlen == e_star) { + len = fromlen; + if (datumtype == 'Z') len++; + } + GROWING(0, cat, start, cur, len); + if (!S_utf8_to_bytes(aTHX_ &aptr, end, cur, fromlen, + datumtype | TYPE_IS_PACK)) + Perl_croak(aTHX_ "panic: predicted utf8 length not available, " + "for '%c', aptr=%p end=%p cur=%p, fromlen=%zu", + (int)datumtype, aptr, end, cur, fromlen); + cur += fromlen; + len -= fromlen; + } else if (utf8) { + if (howlen == e_star) { + len = fromlen; + if (datumtype == 'Z') len++; + } + if (len <= (SSize_t) fromlen) { + fromlen = len; + if (datumtype == 'Z' && fromlen > 0) fromlen--; + } + /* assumes a byte expands to at most UTF8_EXPAND bytes on + upgrade, so: + expected_length <= from_len*UTF8_EXPAND + (len-from_len) */ + GROWING(0, cat, start, cur, fromlen*(UTF8_EXPAND-1)+len); + len -= fromlen; + while (fromlen > 0) { + cur = (char *) uvchr_to_utf8((U8 *) cur, * (U8 *) aptr); + aptr++; + fromlen--; + } + } else { + string_copy: + if (howlen == e_star) { + len = fromlen; + if (datumtype == 'Z') len++; + } + if (len <= (SSize_t) fromlen) { + fromlen = len; + if (datumtype == 'Z' && fromlen > 0) fromlen--; + } + GROWING(0, cat, start, cur, len); + Copy(aptr, cur, fromlen, char); + cur += fromlen; + len -= fromlen; + } + memset(cur, datumtype == 'A' ? ' ' : '\0', len); + cur += len; + SvTAINT(cat); + break; + } + case 'B': + case 'b': { + const char *str, *end; + SSize_t l, field_len; + U8 bits; + bool utf8_source; + U32 utf8_flags; + + fromstr = NEXTFROM; + str = SvPV_const(fromstr, fromlen); + end = str + fromlen; + if (DO_UTF8(fromstr)) { + utf8_source = TRUE; + utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY; + } else { + utf8_source = FALSE; + utf8_flags = 0; /* Unused, but keep compilers happy */ + } + if (howlen == e_star) len = fromlen; + field_len = (len+7)/8; + GROWING(utf8, cat, start, cur, field_len); + if (len > (SSize_t)fromlen) len = fromlen; + bits = 0; + l = 0; + if (datumtype == 'B') + while (l++ < len) { + if (utf8_source) { + UV val = 0; + NEXT_UNI_VAL(val, cur, str, end, utf8_flags); + bits |= val & 1; + } else bits |= *str++ & 1; + if (l & 7) bits <<= 1; + else { + PUSH_BYTE(utf8, cur, bits); + bits = 0; + } + } + else + /* datumtype == 'b' */ + while (l++ < len) { + if (utf8_source) { + UV val = 0; + NEXT_UNI_VAL(val, cur, str, end, utf8_flags); + if (val & 1) bits |= 0x80; + } else if (*str++ & 1) + bits |= 0x80; + if (l & 7) bits >>= 1; + else { + PUSH_BYTE(utf8, cur, bits); + bits = 0; + } + } + l--; + if (l & 7) { + if (datumtype == 'B') + bits <<= 7 - (l & 7); + else + bits >>= 7 - (l & 7); + PUSH_BYTE(utf8, cur, bits); + l += 7; + } + /* Determine how many chars are left in the requested field */ + l /= 8; + if (howlen == e_star) field_len = 0; + else field_len -= l; + Zero(cur, field_len, char); + cur += field_len; + break; + } + case 'H': + case 'h': { + const char *str, *end; + SSize_t l, field_len; + U8 bits; + bool utf8_source; + U32 utf8_flags; + + fromstr = NEXTFROM; + str = SvPV_const(fromstr, fromlen); + end = str + fromlen; + if (DO_UTF8(fromstr)) { + utf8_source = TRUE; + utf8_flags = warn_utf8 ? 0 : UTF8_ALLOW_ANY; + } else { + utf8_source = FALSE; + utf8_flags = 0; /* Unused, but keep compilers happy */ + } + if (howlen == e_star) len = fromlen; + field_len = (len+1)/2; + GROWING(utf8, cat, start, cur, field_len); + if (!utf8_source && len > (SSize_t)fromlen) len = fromlen; + bits = 0; + l = 0; + if (datumtype == 'H') + while (l++ < len) { + if (utf8_source) { + UV val = 0; + NEXT_UNI_VAL(val, cur, str, end, utf8_flags); + if (val < 256 && isALPHA(val)) + bits |= (val + 9) & 0xf; + else + bits |= val & 0xf; + } else if (isALPHA(*str)) + bits |= (*str++ + 9) & 0xf; + else + bits |= *str++ & 0xf; + if (l & 1) bits <<= 4; + else { + PUSH_BYTE(utf8, cur, bits); + bits = 0; + } + } + else + while (l++ < len) { + if (utf8_source) { + UV val = 0; + NEXT_UNI_VAL(val, cur, str, end, utf8_flags); + if (val < 256 && isALPHA(val)) + bits |= ((val + 9) & 0xf) << 4; + else + bits |= (val & 0xf) << 4; + } else if (isALPHA(*str)) + bits |= ((*str++ + 9) & 0xf) << 4; + else + bits |= (*str++ & 0xf) << 4; + if (l & 1) bits >>= 4; + else { + PUSH_BYTE(utf8, cur, bits); + bits = 0; + } + } + l--; + if (l & 1) { + PUSH_BYTE(utf8, cur, bits); + l++; + } + /* Determine how many chars are left in the requested field */ + l /= 2; + if (howlen == e_star) field_len = 0; + else field_len -= l; + Zero(cur, field_len, char); + cur += field_len; + break; + } + case 'c': + while (len-- > 0) { + IV aiv; + fromstr = NEXTFROM; aiv = SvIV_no_inf(fromstr, datumtype); - if ((-128 > aiv || aiv > 127)) - Perl_ck_warner(aTHX_ packWARN(WARN_PACK), - "Character in 'c' format wrapped in pack"); - PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff)); - } - break; - case 'C': - if (len == 0) { - utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; - break; - } - while (len-- > 0) { - IV aiv; - fromstr = NEXTFROM; + if ((-128 > aiv || aiv > 127)) + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'c' format wrapped in pack"); + PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff)); + } + break; + case 'C': + if (len == 0) { + utf8 = (symptr->flags & FLAG_DO_UTF8) ? 1 : 0; + break; + } + while (len-- > 0) { + IV aiv; + fromstr = NEXTFROM; aiv = SvIV_no_inf(fromstr, datumtype); - if ((0 > aiv || aiv > 0xff)) - Perl_ck_warner(aTHX_ packWARN(WARN_PACK), - "Character in 'C' format wrapped in pack"); - PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff)); - } - break; - case 'W': { - char *end; - U8 in_bytes = (U8)IN_BYTES; - - end = start+SvLEN(cat)-1; - if (utf8) end -= UTF8_MAXLEN-1; - while (len-- > 0) { - UV auv; - fromstr = NEXTFROM; - auv = SvUV_no_inf(fromstr, datumtype); - if (in_bytes) auv = auv % 0x100; - if (utf8) { - W_utf8: - if (cur >= end) { - *cur = '\0'; - SvCUR_set(cat, cur - start); - - GROWING(0, cat, start, cur, len+UTF8_MAXLEN); - end = start+SvLEN(cat)-UTF8_MAXLEN; - } - cur = (char *) uvchr_to_utf8_flags((U8 *) cur, auv, 0); - } else { - if (auv >= 0x100) { - if (!SvUTF8(cat)) { - *cur = '\0'; - SvCUR_set(cat, cur - start); - marked_upgrade(aTHX_ cat, symptr); - lookahead.flags |= FLAG_DO_UTF8; - lookahead.strbeg = symptr->strbeg; - utf8 = 1; - start = SvPVX(cat); - cur = start + SvCUR(cat); - end = start+SvLEN(cat)-UTF8_MAXLEN; - goto W_utf8; - } - Perl_ck_warner(aTHX_ packWARN(WARN_PACK), - "Character in 'W' format wrapped in pack"); - auv &= 0xff; - } - if (cur >= end) { - *cur = '\0'; - SvCUR_set(cat, cur - start); - GROWING(0, cat, start, cur, len+1); - end = start+SvLEN(cat)-1; - } - *(U8 *) cur++ = (U8)auv; - } - } - break; - } - case 'U': { - char *end; - - if (len == 0) { - if (!(symptr->flags & FLAG_DO_UTF8)) { - marked_upgrade(aTHX_ cat, symptr); - lookahead.flags |= FLAG_DO_UTF8; - lookahead.strbeg = symptr->strbeg; - } - utf8 = 0; - goto no_change; - } - - end = start+SvLEN(cat); - if (!utf8) end -= UTF8_MAXLEN; - while (len-- > 0) { - UV auv; - fromstr = NEXTFROM; - auv = SvUV_no_inf(fromstr, datumtype); - if (utf8) { - U8 buffer[UTF8_MAXLEN+1], *endb; - endb = uvchr_to_utf8_flags(buffer, UNI_TO_NATIVE(auv), 0); - if (cur+(endb-buffer)*UTF8_EXPAND >= end) { - *cur = '\0'; - SvCUR_set(cat, cur - start); - GROWING(0, cat, start, cur, - len+(endb-buffer)*UTF8_EXPAND); - end = start+SvLEN(cat); - } + if ((0 > aiv || aiv > 0xff)) + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'C' format wrapped in pack"); + PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff)); + } + break; + case 'W': { + char *end; + U8 in_bytes = (U8)IN_BYTES; + + end = start+SvLEN(cat)-1; + if (utf8) end -= UTF8_MAXLEN-1; + while (len-- > 0) { + UV auv; + fromstr = NEXTFROM; + auv = SvUV_no_inf(fromstr, datumtype); + if (in_bytes) auv = auv % 0x100; + if (utf8) { + W_utf8: + if (cur >= end) { + *cur = '\0'; + SvCUR_set(cat, cur - start); + + GROWING(0, cat, start, cur, len+UTF8_MAXLEN); + end = start+SvLEN(cat)-UTF8_MAXLEN; + } + cur = (char *) uvchr_to_utf8_flags((U8 *) cur, auv, 0); + } else { + if (auv >= 0x100) { + if (!SvUTF8(cat)) { + *cur = '\0'; + SvCUR_set(cat, cur - start); + marked_upgrade(aTHX_ cat, symptr); + lookahead.flags |= FLAG_DO_UTF8; + lookahead.strbeg = symptr->strbeg; + utf8 = 1; + start = SvPVX(cat); + cur = start + SvCUR(cat); + end = start+SvLEN(cat)-UTF8_MAXLEN; + goto W_utf8; + } + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'W' format wrapped in pack"); + auv &= 0xff; + } + if (cur >= end) { + *cur = '\0'; + SvCUR_set(cat, cur - start); + GROWING(0, cat, start, cur, len+1); + end = start+SvLEN(cat)-1; + } + *(U8 *) cur++ = (U8)auv; + } + } + break; + } + case 'U': { + char *end; + + if (len == 0) { + if (!(symptr->flags & FLAG_DO_UTF8)) { + marked_upgrade(aTHX_ cat, symptr); + lookahead.flags |= FLAG_DO_UTF8; + lookahead.strbeg = symptr->strbeg; + } + utf8 = 0; + goto no_change; + } + + end = start+SvLEN(cat); + if (!utf8) end -= UTF8_MAXLEN; + while (len-- > 0) { + UV auv; + fromstr = NEXTFROM; + auv = SvUV_no_inf(fromstr, datumtype); + if (utf8) { + U8 buffer[UTF8_MAXLEN+1], *endb; + endb = uvchr_to_utf8_flags(buffer, UNI_TO_NATIVE(auv), 0); + if (cur+(endb-buffer)*UTF8_EXPAND >= end) { + *cur = '\0'; + SvCUR_set(cat, cur - start); + GROWING(0, cat, start, cur, + len+(endb-buffer)*UTF8_EXPAND); + end = start+SvLEN(cat); + } cur = my_bytes_to_utf8(buffer, endb-buffer, cur, 0); - } else { - if (cur >= end) { - *cur = '\0'; - SvCUR_set(cat, cur - start); - GROWING(0, cat, start, cur, len+UTF8_MAXLEN); - end = start+SvLEN(cat)-UTF8_MAXLEN; - } - cur = (char *) uvchr_to_utf8_flags((U8 *) cur, + } else { + if (cur >= end) { + *cur = '\0'; + SvCUR_set(cat, cur - start); + GROWING(0, cat, start, cur, len+UTF8_MAXLEN); + end = start+SvLEN(cat)-UTF8_MAXLEN; + } + cur = (char *) uvchr_to_utf8_flags((U8 *) cur, UNI_TO_NATIVE(auv), - 0); - } - } - break; - } - /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ - case 'f': - while (len-- > 0) { - float afloat; - NV anv; - fromstr = NEXTFROM; - anv = SvNV(fromstr); + 0); + } + } + break; + } + /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ + case 'f': + while (len-- > 0) { + float afloat; + NV anv; + fromstr = NEXTFROM; + anv = SvNV(fromstr); # if (defined(VMS) && !defined(_IEEE_FP)) || defined(DOUBLE_IS_VAX_FLOAT) - /* IEEE fp overflow shenanigans are unavailable on VAX and optional - * on Alpha; fake it if we don't have them. - */ - if (anv > FLT_MAX) - afloat = FLT_MAX; - else if (anv < -FLT_MAX) - afloat = -FLT_MAX; - else afloat = (float)anv; + /* IEEE fp overflow shenanigans are unavailable on VAX and optional + * on Alpha; fake it if we don't have them. + */ + if (anv > FLT_MAX) + afloat = FLT_MAX; + else if (anv < -FLT_MAX) + afloat = -FLT_MAX; + else afloat = (float)anv; # else # if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - if(Perl_isnan(anv)) - afloat = (float)NV_NAN; - else + if(Perl_isnan(anv)) + afloat = (float)NV_NAN; + else # endif # ifdef NV_INF /* a simple cast to float is undefined if outside * the range of values that can be represented */ - afloat = (float)(anv > FLT_MAX ? NV_INF : + afloat = (float)(anv > FLT_MAX ? NV_INF : anv < -FLT_MAX ? -NV_INF : anv); # endif # endif PUSH_VAR(utf8, cur, afloat, needs_swap); - } - break; - case 'd': - while (len-- > 0) { - double adouble; - NV anv; - fromstr = NEXTFROM; - anv = SvNV(fromstr); + } + break; + case 'd': + while (len-- > 0) { + double adouble; + NV anv; + fromstr = NEXTFROM; + anv = SvNV(fromstr); # if (defined(VMS) && !defined(_IEEE_FP)) || defined(DOUBLE_IS_VAX_FLOAT) - /* IEEE fp overflow shenanigans are unavailable on VAX and optional - * on Alpha; fake it if we don't have them. - */ - if (anv > DBL_MAX) - adouble = DBL_MAX; - else if (anv < -DBL_MAX) - adouble = -DBL_MAX; - else adouble = (double)anv; + /* IEEE fp overflow shenanigans are unavailable on VAX and optional + * on Alpha; fake it if we don't have them. + */ + if (anv > DBL_MAX) + adouble = DBL_MAX; + else if (anv < -DBL_MAX) + adouble = -DBL_MAX; + else adouble = (double)anv; # else - adouble = (double)anv; + adouble = (double)anv; # endif PUSH_VAR(utf8, cur, adouble, needs_swap); - } - break; - case 'F': { - NV_bytes anv; - Zero(&anv, 1, NV); /* can be long double with unused bits */ - while (len-- > 0) { - fromstr = NEXTFROM; + } + break; + case 'F': { + NV_bytes anv; + Zero(&anv, 1, NV); /* can be long double with unused bits */ + while (len-- > 0) { + fromstr = NEXTFROM; #ifdef __GNUC__ - /* to work round a gcc/x86 bug; don't use SvNV */ - anv.nv = sv_2nv(fromstr); + /* to work round a gcc/x86 bug; don't use SvNV */ + anv.nv = sv_2nv(fromstr); # if defined(LONGDOUBLE_X86_80_BIT) && defined(USE_LONG_DOUBLE) \ && LONG_DOUBLESIZE > 10 /* GCC sometimes overwrites the padding in the @@ -2753,380 +2753,380 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) Zero(anv.bytes+10, sizeof(anv.bytes) - 10, U8); # endif #else - anv.nv = SvNV(fromstr); + anv.nv = SvNV(fromstr); #endif PUSH_BYTES(utf8, cur, anv.bytes, sizeof(anv.bytes), needs_swap); - } - break; - } + } + break; + } #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) - case 'D': { - ld_bytes aldouble; - /* long doubles can have unused bits, which may be nonzero */ - Zero(&aldouble, 1, long double); - while (len-- > 0) { - fromstr = NEXTFROM; + case 'D': { + ld_bytes aldouble; + /* long doubles can have unused bits, which may be nonzero */ + Zero(&aldouble, 1, long double); + while (len-- > 0) { + fromstr = NEXTFROM; # ifdef __GNUC__ - /* to work round a gcc/x86 bug; don't use SvNV */ - aldouble.ld = (long double)sv_2nv(fromstr); + /* to work round a gcc/x86 bug; don't use SvNV */ + aldouble.ld = (long double)sv_2nv(fromstr); # if defined(LONGDOUBLE_X86_80_BIT) && LONG_DOUBLESIZE > 10 /* GCC sometimes overwrites the padding in the assignment above */ Zero(aldouble.bytes+10, sizeof(aldouble.bytes) - 10, U8); # endif # else - aldouble.ld = (long double)SvNV(fromstr); + aldouble.ld = (long double)SvNV(fromstr); # endif PUSH_BYTES(utf8, cur, aldouble.bytes, sizeof(aldouble.bytes), needs_swap); - } - break; - } + } + break; + } #endif - case 'n' | TYPE_IS_SHRIEKING: - case 'n': - while (len-- > 0) { - I16 ai16; - fromstr = NEXTFROM; - ai16 = (I16)SvIV_no_inf(fromstr, datumtype); - ai16 = PerlSock_htons(ai16); + case 'n' | TYPE_IS_SHRIEKING: + case 'n': + while (len-- > 0) { + I16 ai16; + fromstr = NEXTFROM; + ai16 = (I16)SvIV_no_inf(fromstr, datumtype); + ai16 = PerlSock_htons(ai16); PUSH16(utf8, cur, &ai16, FALSE); - } - break; - case 'v' | TYPE_IS_SHRIEKING: - case 'v': - while (len-- > 0) { - I16 ai16; - fromstr = NEXTFROM; - ai16 = (I16)SvIV_no_inf(fromstr, datumtype); - ai16 = htovs(ai16); + } + break; + case 'v' | TYPE_IS_SHRIEKING: + case 'v': + while (len-- > 0) { + I16 ai16; + fromstr = NEXTFROM; + ai16 = (I16)SvIV_no_inf(fromstr, datumtype); + ai16 = htovs(ai16); PUSH16(utf8, cur, &ai16, FALSE); - } - break; + } + break; case 'S' | TYPE_IS_SHRIEKING: #if SHORTSIZE != SIZE16 - while (len-- > 0) { - unsigned short aushort; - fromstr = NEXTFROM; - aushort = SvUV_no_inf(fromstr, datumtype); + while (len-- > 0) { + unsigned short aushort; + fromstr = NEXTFROM; + aushort = SvUV_no_inf(fromstr, datumtype); PUSH_VAR(utf8, cur, aushort, needs_swap); - } + } break; #else /* FALLTHROUGH */ #endif - case 'S': - while (len-- > 0) { - U16 au16; - fromstr = NEXTFROM; - au16 = (U16)SvUV_no_inf(fromstr, datumtype); + case 'S': + while (len-- > 0) { + U16 au16; + fromstr = NEXTFROM; + au16 = (U16)SvUV_no_inf(fromstr, datumtype); PUSH16(utf8, cur, &au16, needs_swap); - } - break; - case 's' | TYPE_IS_SHRIEKING: + } + break; + case 's' | TYPE_IS_SHRIEKING: #if SHORTSIZE != SIZE16 - while (len-- > 0) { - short ashort; - fromstr = NEXTFROM; - ashort = SvIV_no_inf(fromstr, datumtype); + while (len-- > 0) { + short ashort; + fromstr = NEXTFROM; + ashort = SvIV_no_inf(fromstr, datumtype); PUSH_VAR(utf8, cur, ashort, needs_swap); - } + } break; #else /* FALLTHROUGH */ #endif - case 's': - while (len-- > 0) { - I16 ai16; - fromstr = NEXTFROM; - ai16 = (I16)SvIV_no_inf(fromstr, datumtype); + case 's': + while (len-- > 0) { + I16 ai16; + fromstr = NEXTFROM; + ai16 = (I16)SvIV_no_inf(fromstr, datumtype); PUSH16(utf8, cur, &ai16, needs_swap); - } - break; - case 'I': - case 'I' | TYPE_IS_SHRIEKING: - while (len-- > 0) { - unsigned int auint; - fromstr = NEXTFROM; - auint = SvUV_no_inf(fromstr, datumtype); + } + break; + case 'I': + case 'I' | TYPE_IS_SHRIEKING: + while (len-- > 0) { + unsigned int auint; + fromstr = NEXTFROM; + auint = SvUV_no_inf(fromstr, datumtype); PUSH_VAR(utf8, cur, auint, needs_swap); - } - break; - case 'j': - while (len-- > 0) { - IV aiv; - fromstr = NEXTFROM; - aiv = SvIV_no_inf(fromstr, datumtype); + } + break; + case 'j': + while (len-- > 0) { + IV aiv; + fromstr = NEXTFROM; + aiv = SvIV_no_inf(fromstr, datumtype); PUSH_VAR(utf8, cur, aiv, needs_swap); - } - break; - case 'J': - while (len-- > 0) { - UV auv; - fromstr = NEXTFROM; - auv = SvUV_no_inf(fromstr, datumtype); + } + break; + case 'J': + while (len-- > 0) { + UV auv; + fromstr = NEXTFROM; + auv = SvUV_no_inf(fromstr, datumtype); PUSH_VAR(utf8, cur, auv, needs_swap); - } - break; - case 'w': + } + break; + case 'w': while (len-- > 0) { - NV anv; - fromstr = NEXTFROM; - S_sv_check_infnan(aTHX_ fromstr, datumtype); - anv = SvNV_nomg(fromstr); - - if (anv < 0) { - *cur = '\0'; - SvCUR_set(cat, cur - start); - Perl_croak(aTHX_ "Cannot compress negative numbers in pack"); - } + NV anv; + fromstr = NEXTFROM; + S_sv_check_infnan(aTHX_ fromstr, datumtype); + anv = SvNV_nomg(fromstr); + + if (anv < 0) { + *cur = '\0'; + SvCUR_set(cat, cur - start); + Perl_croak(aTHX_ "Cannot compress negative numbers in pack"); + } /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0, which is == UV_MAX_P1. IOK is fine (instead of UV_only), as any negative IVs will have already been got by the croak() above. IOK is untrue for fractions, so we test them against UV_MAX_P1. */ - if (SvIOK(fromstr) || anv < UV_MAX_P1) { - char buf[(sizeof(UV)*CHAR_BIT)/7+1]; - char *in = buf + sizeof(buf); - UV auv = SvUV_nomg(fromstr); - - do { - *--in = (char)((auv & 0x7f) | 0x80); - auv >>= 7; - } while (auv); - buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ - PUSH_GROWING_BYTES(utf8, cat, start, cur, - in, (buf + sizeof(buf)) - in); - } else if (SvPOKp(fromstr)) - goto w_string; - else if (SvNOKp(fromstr)) { - /* 10**NV_MAX_10_EXP is the largest power of 10 - so 10**(NV_MAX_10_EXP+1) is definitely unrepresentable - given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x: - x = (NV_MAX_10_EXP+1) * log (10) / log (128) - And with that many bytes only Inf can overflow. - Some C compilers are strict about integral constant - expressions so we conservatively divide by a slightly - smaller integer instead of multiplying by the exact - floating-point value. - */ + if (SvIOK(fromstr) || anv < UV_MAX_P1) { + char buf[(sizeof(UV)*CHAR_BIT)/7+1]; + char *in = buf + sizeof(buf); + UV auv = SvUV_nomg(fromstr); + + do { + *--in = (char)((auv & 0x7f) | 0x80); + auv >>= 7; + } while (auv); + buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ + PUSH_GROWING_BYTES(utf8, cat, start, cur, + in, (buf + sizeof(buf)) - in); + } else if (SvPOKp(fromstr)) + goto w_string; + else if (SvNOKp(fromstr)) { + /* 10**NV_MAX_10_EXP is the largest power of 10 + so 10**(NV_MAX_10_EXP+1) is definitely unrepresentable + given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x: + x = (NV_MAX_10_EXP+1) * log (10) / log (128) + And with that many bytes only Inf can overflow. + Some C compilers are strict about integral constant + expressions so we conservatively divide by a slightly + smaller integer instead of multiplying by the exact + floating-point value. + */ #ifdef NV_MAX_10_EXP - /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */ - char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */ + /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */ + char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */ #else - /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */ - char buf[1 + (int)((308 + 1) / 2)]; /* valid C */ + /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */ + char buf[1 + (int)((308 + 1) / 2)]; /* valid C */ #endif - char *in = buf + sizeof(buf); - - anv = Perl_floor(anv); - do { - const NV next = Perl_floor(anv / 128); - if (in <= buf) /* this cannot happen ;-) */ - Perl_croak(aTHX_ "Cannot compress integer in pack"); - *--in = (unsigned char)(anv - (next * 128)) | 0x80; - anv = next; - } while (anv > 0); - buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ - PUSH_GROWING_BYTES(utf8, cat, start, cur, - in, (buf + sizeof(buf)) - in); - } else { - const char *from; - char *result, *in; - SV *norm; - STRLEN len; - bool done; - - w_string: - /* Copy string and check for compliance */ - from = SvPV_nomg_const(fromstr, len); - if ((norm = is_an_int(from, len)) == NULL) - Perl_croak(aTHX_ "Can only compress unsigned integers in pack"); - - Newx(result, len, char); - in = result + len; - done = FALSE; - while (!done) *--in = div128(norm, &done) | 0x80; - result[len - 1] &= 0x7F; /* clear continue bit */ - PUSH_GROWING_BYTES(utf8, cat, start, cur, - in, (result + len) - in); - Safefree(result); - SvREFCNT_dec(norm); /* free norm */ - } - } - break; - case 'i': - case 'i' | TYPE_IS_SHRIEKING: - while (len-- > 0) { - int aint; - fromstr = NEXTFROM; - aint = SvIV_no_inf(fromstr, datumtype); + char *in = buf + sizeof(buf); + + anv = Perl_floor(anv); + do { + const NV next = Perl_floor(anv / 128); + if (in <= buf) /* this cannot happen ;-) */ + Perl_croak(aTHX_ "Cannot compress integer in pack"); + *--in = (unsigned char)(anv - (next * 128)) | 0x80; + anv = next; + } while (anv > 0); + buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ + PUSH_GROWING_BYTES(utf8, cat, start, cur, + in, (buf + sizeof(buf)) - in); + } else { + const char *from; + char *result, *in; + SV *norm; + STRLEN len; + bool done; + + w_string: + /* Copy string and check for compliance */ + from = SvPV_nomg_const(fromstr, len); + if ((norm = is_an_int(from, len)) == NULL) + Perl_croak(aTHX_ "Can only compress unsigned integers in pack"); + + Newx(result, len, char); + in = result + len; + done = FALSE; + while (!done) *--in = div128(norm, &done) | 0x80; + result[len - 1] &= 0x7F; /* clear continue bit */ + PUSH_GROWING_BYTES(utf8, cat, start, cur, + in, (result + len) - in); + Safefree(result); + SvREFCNT_dec(norm); /* free norm */ + } + } + break; + case 'i': + case 'i' | TYPE_IS_SHRIEKING: + while (len-- > 0) { + int aint; + fromstr = NEXTFROM; + aint = SvIV_no_inf(fromstr, datumtype); PUSH_VAR(utf8, cur, aint, needs_swap); - } - break; - case 'N' | TYPE_IS_SHRIEKING: - case 'N': - while (len-- > 0) { - U32 au32; - fromstr = NEXTFROM; - au32 = SvUV_no_inf(fromstr, datumtype); - au32 = PerlSock_htonl(au32); + } + break; + case 'N' | TYPE_IS_SHRIEKING: + case 'N': + while (len-- > 0) { + U32 au32; + fromstr = NEXTFROM; + au32 = SvUV_no_inf(fromstr, datumtype); + au32 = PerlSock_htonl(au32); PUSH32(utf8, cur, &au32, FALSE); - } - break; - case 'V' | TYPE_IS_SHRIEKING: - case 'V': - while (len-- > 0) { - U32 au32; - fromstr = NEXTFROM; - au32 = SvUV_no_inf(fromstr, datumtype); - au32 = htovl(au32); + } + break; + case 'V' | TYPE_IS_SHRIEKING: + case 'V': + while (len-- > 0) { + U32 au32; + fromstr = NEXTFROM; + au32 = SvUV_no_inf(fromstr, datumtype); + au32 = htovl(au32); PUSH32(utf8, cur, &au32, FALSE); - } - break; - case 'L' | TYPE_IS_SHRIEKING: + } + break; + case 'L' | TYPE_IS_SHRIEKING: #if LONGSIZE != SIZE32 - while (len-- > 0) { - unsigned long aulong; - fromstr = NEXTFROM; - aulong = SvUV_no_inf(fromstr, datumtype); + while (len-- > 0) { + unsigned long aulong; + fromstr = NEXTFROM; + aulong = SvUV_no_inf(fromstr, datumtype); PUSH_VAR(utf8, cur, aulong, needs_swap); - } - break; + } + break; #else /* Fall though! */ #endif - case 'L': - while (len-- > 0) { - U32 au32; - fromstr = NEXTFROM; - au32 = SvUV_no_inf(fromstr, datumtype); + case 'L': + while (len-- > 0) { + U32 au32; + fromstr = NEXTFROM; + au32 = SvUV_no_inf(fromstr, datumtype); PUSH32(utf8, cur, &au32, needs_swap); - } - break; - case 'l' | TYPE_IS_SHRIEKING: + } + break; + case 'l' | TYPE_IS_SHRIEKING: #if LONGSIZE != SIZE32 - while (len-- > 0) { - long along; - fromstr = NEXTFROM; - along = SvIV_no_inf(fromstr, datumtype); + while (len-- > 0) { + long along; + fromstr = NEXTFROM; + along = SvIV_no_inf(fromstr, datumtype); PUSH_VAR(utf8, cur, along, needs_swap); - } - break; + } + break; #else /* Fall though! */ #endif - case 'l': + case 'l': while (len-- > 0) { - I32 ai32; - fromstr = NEXTFROM; - ai32 = SvIV_no_inf(fromstr, datumtype); + I32 ai32; + fromstr = NEXTFROM; + ai32 = SvIV_no_inf(fromstr, datumtype); PUSH32(utf8, cur, &ai32, needs_swap); - } - break; + } + break; #if defined(HAS_QUAD) && IVSIZE >= 8 - case 'Q': - while (len-- > 0) { - Uquad_t auquad; - fromstr = NEXTFROM; - auquad = (Uquad_t) SvUV_no_inf(fromstr, datumtype); + case 'Q': + while (len-- > 0) { + Uquad_t auquad; + fromstr = NEXTFROM; + auquad = (Uquad_t) SvUV_no_inf(fromstr, datumtype); PUSH_VAR(utf8, cur, auquad, needs_swap); - } - break; - case 'q': - while (len-- > 0) { - Quad_t aquad; - fromstr = NEXTFROM; - aquad = (Quad_t)SvIV_no_inf(fromstr, datumtype); + } + break; + case 'q': + while (len-- > 0) { + Quad_t aquad; + fromstr = NEXTFROM; + aquad = (Quad_t)SvIV_no_inf(fromstr, datumtype); PUSH_VAR(utf8, cur, aquad, needs_swap); - } - break; + } + break; #endif - case 'P': - len = 1; /* assume SV is correct length */ - GROWING(utf8, cat, start, cur, sizeof(char *)); - /* FALLTHROUGH */ - case 'p': - while (len-- > 0) { - const char *aptr; - - fromstr = NEXTFROM; - SvGETMAGIC(fromstr); - if (!SvOK(fromstr)) aptr = NULL; - else { - /* XXX better yet, could spirit away the string to - * a safe spot and hang on to it until the result - * of pack() (and all copies of the result) are - * gone. - */ - if (((SvTEMP(fromstr) && SvREFCNT(fromstr) == 1) - || (SvPADTMP(fromstr) && - !SvREADONLY(fromstr)))) { - Perl_ck_warner(aTHX_ packWARN(WARN_PACK), - "Attempt to pack pointer to temporary value"); - } - if (SvPOK(fromstr) || SvNIOK(fromstr)) - aptr = SvPV_nomg_const_nolen(fromstr); - else - aptr = SvPV_force_flags_nolen(fromstr, 0); - } + case 'P': + len = 1; /* assume SV is correct length */ + GROWING(utf8, cat, start, cur, sizeof(char *)); + /* FALLTHROUGH */ + case 'p': + while (len-- > 0) { + const char *aptr; + + fromstr = NEXTFROM; + SvGETMAGIC(fromstr); + if (!SvOK(fromstr)) aptr = NULL; + else { + /* XXX better yet, could spirit away the string to + * a safe spot and hang on to it until the result + * of pack() (and all copies of the result) are + * gone. + */ + if (((SvTEMP(fromstr) && SvREFCNT(fromstr) == 1) + || (SvPADTMP(fromstr) && + !SvREADONLY(fromstr)))) { + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Attempt to pack pointer to temporary value"); + } + if (SvPOK(fromstr) || SvNIOK(fromstr)) + aptr = SvPV_nomg_const_nolen(fromstr); + else + aptr = SvPV_force_flags_nolen(fromstr, 0); + } PUSH_VAR(utf8, cur, aptr, needs_swap); - } - break; - case 'u': { - const char *aptr, *aend; - bool from_utf8; - - fromstr = NEXTFROM; - if (len <= 2) len = 45; - else len = len / 3 * 3; - if (len >= 64) { - Perl_ck_warner(aTHX_ packWARN(WARN_PACK), - "Field too wide in 'u' format in pack"); - len = 63; - } - aptr = SvPV_const(fromstr, fromlen); - from_utf8 = DO_UTF8(fromstr); - if (from_utf8) { - aend = aptr + fromlen; - fromlen = sv_len_utf8_nomg(fromstr); - } else aend = NULL; /* Unused, but keep compilers happy */ - GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2); - while (fromlen > 0) { - U8 *end; - SSize_t todo; - U8 hunk[1+63/3*4+1]; - - if ((SSize_t)fromlen > len) - todo = len; - else - todo = fromlen; - if (from_utf8) { - char buffer[64]; - if (!S_utf8_to_bytes(aTHX_ &aptr, aend, buffer, todo, - 'u' | TYPE_IS_PACK)) { - *cur = '\0'; - SvCUR_set(cat, cur - start); - Perl_croak(aTHX_ "panic: string is shorter than advertised, " - "aptr=%p, aend=%p, buffer=%p, todo=%zd", - aptr, aend, buffer, todo); - } - end = doencodes(hunk, (const U8 *)buffer, todo); - } else { - end = doencodes(hunk, (const U8 *)aptr, todo); - aptr += todo; - } - PUSH_BYTES(utf8, cur, hunk, end-hunk, 0); - fromlen -= todo; - } - break; - } - } - *cur = '\0'; - SvCUR_set(cat, cur - start); + } + break; + case 'u': { + const char *aptr, *aend; + bool from_utf8; + + fromstr = NEXTFROM; + if (len <= 2) len = 45; + else len = len / 3 * 3; + if (len >= 64) { + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Field too wide in 'u' format in pack"); + len = 63; + } + aptr = SvPV_const(fromstr, fromlen); + from_utf8 = DO_UTF8(fromstr); + if (from_utf8) { + aend = aptr + fromlen; + fromlen = sv_len_utf8_nomg(fromstr); + } else aend = NULL; /* Unused, but keep compilers happy */ + GROWING(utf8, cat, start, cur, (fromlen+2) / 3 * 4 + (fromlen+len-1)/len * 2); + while (fromlen > 0) { + U8 *end; + SSize_t todo; + U8 hunk[1+63/3*4+1]; + + if ((SSize_t)fromlen > len) + todo = len; + else + todo = fromlen; + if (from_utf8) { + char buffer[64]; + if (!S_utf8_to_bytes(aTHX_ &aptr, aend, buffer, todo, + 'u' | TYPE_IS_PACK)) { + *cur = '\0'; + SvCUR_set(cat, cur - start); + Perl_croak(aTHX_ "panic: string is shorter than advertised, " + "aptr=%p, aend=%p, buffer=%p, todo=%zd", + aptr, aend, buffer, todo); + } + end = doencodes(hunk, (const U8 *)buffer, todo); + } else { + end = doencodes(hunk, (const U8 *)aptr, todo); + aptr += todo; + } + PUSH_BYTES(utf8, cur, hunk, end-hunk, 0); + fromlen -= todo; + } + break; + } + } + *cur = '\0'; + SvCUR_set(cat, cur - start); no_change: - *symptr = lookahead; + *symptr = lookahead; } return beglist; } @@ -220,7 +220,7 @@ void endservent(void); #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \ && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \ - || defined(HAS_SETREGID) || defined(HAS_SETRESGID)) + || defined(HAS_SETREGID) || defined(HAS_SETRESGID)) /* The Hard Way. */ STATIC int S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) @@ -239,8 +239,8 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) # elif defined(HAS_SETRESUID) if (setresuid(euid, ruid, (Uid_t)-1)) # endif - /* diag_listed_as: entering effective %s failed */ - Perl_croak(aTHX_ "entering effective uid failed"); + /* diag_listed_as: entering effective %s failed */ + Perl_croak(aTHX_ "entering effective uid failed"); #endif #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID) @@ -251,8 +251,8 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) # elif defined(HAS_SETRESGID) if (setresgid(egid, rgid, (Gid_t)-1)) # endif - /* diag_listed_as: entering effective %s failed */ - Perl_croak(aTHX_ "entering effective gid failed"); + /* diag_listed_as: entering effective %s failed */ + Perl_croak(aTHX_ "entering effective gid failed"); #endif res = access(path, mode); @@ -262,16 +262,16 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) #elif defined(HAS_SETRESUID) if (setresuid(ruid, euid, (Uid_t)-1)) #endif - /* diag_listed_as: leaving effective %s failed */ - Perl_croak(aTHX_ "leaving effective uid failed"); + /* diag_listed_as: leaving effective %s failed */ + Perl_croak(aTHX_ "leaving effective uid failed"); #ifdef HAS_SETREGID if (setregid(rgid, egid)) #elif defined(HAS_SETRESGID) if (setresgid(rgid, egid, (Gid_t)-1)) #endif - /* diag_listed_as: leaving effective %s failed */ - Perl_croak(aTHX_ "leaving effective gid failed"); + /* diag_listed_as: leaving effective %s failed */ + Perl_croak(aTHX_ "leaving effective gid failed"); return res; } @@ -288,52 +288,52 @@ PP(pp_backtick) TAINT_PROPER("``"); if (PL_op->op_private & OPpOPEN_IN_RAW) - mode = "rb"; + mode = "rb"; else if (PL_op->op_private & OPpOPEN_IN_CRLF) - mode = "rt"; + mode = "rt"; fp = PerlProc_popen(tmps, mode); if (fp) { const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL); - if (type && *type) - PerlIO_apply_layers(aTHX_ fp,mode,type); - - if (gimme == G_VOID) { - char tmpbuf[256]; - while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0) - NOOP; - } - else if (gimme == G_SCALAR) { - ENTER_with_name("backtick"); - SAVESPTR(PL_rs); - PL_rs = &PL_sv_undef; + if (type && *type) + PerlIO_apply_layers(aTHX_ fp,mode,type); + + if (gimme == G_VOID) { + char tmpbuf[256]; + while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0) + NOOP; + } + else if (gimme == G_SCALAR) { + ENTER_with_name("backtick"); + SAVESPTR(PL_rs); + PL_rs = &PL_sv_undef; SvPVCLEAR(TARG); /* note that this preserves previous buffer */ - while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL) - NOOP; - LEAVE_with_name("backtick"); - XPUSHs(TARG); - SvTAINTED_on(TARG); - } - else { - for (;;) { - SV * const sv = newSV(79); - if (sv_gets(sv, fp, 0) == NULL) { - SvREFCNT_dec(sv); - break; - } - mXPUSHs(sv); - if (SvLEN(sv) - SvCUR(sv) > 20) { - SvPV_shrink_to_cur(sv); - } - SvTAINTED_on(sv); - } - } - STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp)); - TAINT; /* "I believe that this is not gratuitous!" */ + while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL) + NOOP; + LEAVE_with_name("backtick"); + XPUSHs(TARG); + SvTAINTED_on(TARG); + } + else { + for (;;) { + SV * const sv = newSV(79); + if (sv_gets(sv, fp, 0) == NULL) { + SvREFCNT_dec(sv); + break; + } + mXPUSHs(sv); + if (SvLEN(sv) - SvCUR(sv) > 20) { + SvPV_shrink_to_cur(sv); + } + SvTAINTED_on(sv); + } + } + STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp)); + TAINT; /* "I believe that this is not gratuitous!" */ } else { - STATUS_NATIVE_CHILD_SET(-1); - if (gimme == G_SCALAR) - RETPUSHUNDEF; + STATUS_NATIVE_CHILD_SET(-1); + if (gimme == G_SCALAR) + RETPUSHUNDEF; } RETURN; @@ -354,15 +354,15 @@ PP(pp_glob) tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL)); if (PL_op->op_flags & OPf_SPECIAL) { - /* call Perl-level glob function instead. Stack args are: - * MARK, wildcard - * and following OPs should be: gv(CORE::GLOBAL::glob), entersub - * */ - return NORMAL; + /* call Perl-level glob function instead. Stack args are: + * MARK, wildcard + * and following OPs should be: gv(CORE::GLOBAL::glob), entersub + * */ + return NORMAL; } if (PL_globhook) { - PL_globhook(aTHX); - return NORMAL; + PL_globhook(aTHX); + return NORMAL; } /* Note that we only ever get here if File::Glob fails to load @@ -373,12 +373,12 @@ PP(pp_glob) #ifndef VMS if (TAINTING_get) { - /* - * The external globbing program may use things we can't control, - * so for security reasons we must assume the worst. - */ - TAINT; - taint_proper(PL_no_security, "glob"); + /* + * The external globbing program may use things we can't control, + * so for security reasons we must assume the worst. + */ + TAINT; + taint_proper(PL_no_security, "glob"); } #endif /* !VMS */ @@ -410,45 +410,45 @@ PP(pp_warn) SV *exsv; STRLEN len; if (SP - MARK > 1) { - dTARGET; - do_join(TARG, &PL_sv_no, MARK, SP); - exsv = TARG; - SP = MARK + 1; + dTARGET; + do_join(TARG, &PL_sv_no, MARK, SP); + exsv = TARG; + SP = MARK + 1; } else if (SP == MARK) { - exsv = &PL_sv_no; - MEXTEND(SP, 1); - SP = MARK + 1; + exsv = &PL_sv_no; + MEXTEND(SP, 1); + SP = MARK + 1; } else { - exsv = TOPs; - if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv); + exsv = TOPs; + if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv); } if (SvROK(exsv) || (SvPV_const(exsv, len), len)) { - /* well-formed exception supplied */ + /* well-formed exception supplied */ } else { SV * const errsv = ERRSV; SvGETMAGIC(errsv); if (SvROK(errsv)) { - if (SvGMAGICAL(errsv)) { - exsv = sv_newmortal(); - sv_setsv_nomg(exsv, errsv); - } - else exsv = errsv; + if (SvGMAGICAL(errsv)) { + exsv = sv_newmortal(); + sv_setsv_nomg(exsv, errsv); + } + else exsv = errsv; } else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) { - exsv = sv_newmortal(); - sv_setsv_nomg(exsv, errsv); - sv_catpvs(exsv, "\t...caught"); + exsv = sv_newmortal(); + sv_setsv_nomg(exsv, errsv); + sv_catpvs(exsv, "\t...caught"); } else { - exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP); + exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP); } } if (SvROK(exsv) && !PL_warnhook) - Perl_warn(aTHX_ "%" SVf, SVfARG(exsv)); + Perl_warn(aTHX_ "%" SVf, SVfARG(exsv)); else warn_sv(exsv); RETSETYES; } @@ -460,51 +460,51 @@ PP(pp_die) STRLEN len; #ifdef VMS VMSISH_HUSHED = - VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH); + VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH); #endif if (SP - MARK != 1) { - dTARGET; - do_join(TARG, &PL_sv_no, MARK, SP); - exsv = TARG; - SP = MARK + 1; + dTARGET; + do_join(TARG, &PL_sv_no, MARK, SP); + exsv = TARG; + SP = MARK + 1; } else { - exsv = TOPs; + exsv = TOPs; } if (SvROK(exsv) || (SvPV_const(exsv, len), len)) { - /* well-formed exception supplied */ + /* well-formed exception supplied */ } else { - SV * const errsv = ERRSV; - SvGETMAGIC(errsv); - if (SvROK(errsv)) { - exsv = errsv; - if (sv_isobject(exsv)) { - HV * const stash = SvSTASH(SvRV(exsv)); - GV * const gv = gv_fetchmethod(stash, "PROPAGATE"); - if (gv) { - SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); - SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop))); - EXTEND(SP, 3); - PUSHMARK(SP); - PUSHs(exsv); - PUSHs(file); - PUSHs(line); - PUTBACK; - call_sv(MUTABLE_SV(GvCV(gv)), - G_SCALAR|G_EVAL|G_KEEPERR); - exsv = sv_mortalcopy(*PL_stack_sp--); - } - } - } - else if (SvOK(errsv) && (SvPV_nomg(errsv,len), len)) { - exsv = sv_mortalcopy(errsv); - sv_catpvs(exsv, "\t...propagated"); - } - else { - exsv = newSVpvs_flags("Died", SVs_TEMP); - } + SV * const errsv = ERRSV; + SvGETMAGIC(errsv); + if (SvROK(errsv)) { + exsv = errsv; + if (sv_isobject(exsv)) { + HV * const stash = SvSTASH(SvRV(exsv)); + GV * const gv = gv_fetchmethod(stash, "PROPAGATE"); + if (gv) { + SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); + SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop))); + EXTEND(SP, 3); + PUSHMARK(SP); + PUSHs(exsv); + PUSHs(file); + PUSHs(line); + PUTBACK; + call_sv(MUTABLE_SV(GvCV(gv)), + G_SCALAR|G_EVAL|G_KEEPERR); + exsv = sv_mortalcopy(*PL_stack_sp--); + } + } + } + else if (SvOK(errsv) && (SvPV_nomg(errsv,len), len)) { + exsv = sv_mortalcopy(errsv); + sv_catpvs(exsv, "\t...propagated"); + } + else { + exsv = newSVpvs_flags("Died", SVs_TEMP); + } } die_sv(exsv); NOT_REACHED; /* NOTREACHED */ @@ -515,7 +515,7 @@ PP(pp_die) OP * Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, - const MAGIC *const mg, const U32 flags, U32 argc, ...) + const MAGIC *const mg, const U32 flags, U32 argc, ...) { SV **orig_sp = sp; I32 ret_args; @@ -547,30 +547,30 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, PUSHMARK(sp); PUSHs(SvTIED_obj(sv, mg)); if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) { - Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */ - sp += argc; + Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */ + sp += argc; } else if (argc) { - const U32 mortalize_not_needed - = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED; - va_list args; - va_start(args, argc); - do { - SV *const arg = va_arg(args, SV *); - if(mortalize_not_needed) - PUSHs(arg); - else - mPUSHs(arg); - } while (--argc); - va_end(args); + const U32 mortalize_not_needed + = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED; + va_list args; + va_start(args, argc); + do { + SV *const arg = va_arg(args, SV *); + if(mortalize_not_needed) + PUSHs(arg); + else + mPUSHs(arg); + } while (--argc); + va_end(args); } PUTBACK; ENTER_with_name("call_tied_method"); if (flags & TIED_METHOD_SAY) { - /* local $\ = "\n" */ - SAVEGENERICSV(PL_ors_sv); - PL_ors_sv = newSVpvs("\n"); + /* local $\ = "\n" */ + SAVEGENERICSV(PL_ors_sv); + PL_ors_sv = newSVpvs("\n"); } ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED); SPAGAIN; @@ -578,10 +578,10 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, POPSTACK; SPAGAIN; if (ret_args) { /* copy results back to original stack */ - EXTEND(sp, ret_args); - Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*); - sp += ret_args; - PUTBACK; + EXTEND(sp, ret_args); + Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*); + sp += ret_args; + PUTBACK; } LEAVE_with_name("call_tied_method"); return NORMAL; @@ -608,42 +608,42 @@ PP(pp_open) GV * const gv = MUTABLE_GV(*++MARK); if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv))) - DIE(aTHX_ PL_no_usym, "filehandle"); + DIE(aTHX_ PL_no_usym, "filehandle"); if ((io = GvIOp(gv))) { - const MAGIC *mg; - IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; - - if (IoDIRP(io)) - Perl_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle", - HEKfARG(GvENAME_HEK(gv))); - - mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { - /* Method's args are same as ours ... */ - /* ... except handle is replaced by the object */ - return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg, - G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, - sp - mark); - } + const MAGIC *mg; + IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; + + if (IoDIRP(io)) + Perl_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle", + HEKfARG(GvENAME_HEK(gv))); + + mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { + /* Method's args are same as ours ... */ + /* ... except handle is replaced by the object */ + return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); + } } if (MARK < SP) { - sv = *++MARK; + sv = *++MARK; } else { - sv = GvSVn(gv); + sv = GvSVn(gv); } tmps = SvPV_const(sv, len); ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK)); SP = ORIGMARK; if (ok) - PUSHi( (I32)PL_forkprocess ); + PUSHi( (I32)PL_forkprocess ); else if (PL_forkprocess == 0) /* we are a new child */ - PUSHs(&PL_sv_zero); + PUSHs(&PL_sv_zero); else - RETPUSHUNDEF; + RETPUSHUNDEF; RETURN; } @@ -653,19 +653,19 @@ PP(pp_close) /* pp_coreargs pushes a NULL to indicate no args passed to * CORE::close() */ GV * const gv = - MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs); + MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs); if (MAXARG == 0) - EXTEND(SP, 1); + EXTEND(SP, 1); if (gv) { - IO * const io = GvIO(gv); - if (io) { - const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { - return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg); - } - } + IO * const io = GvIO(gv); + if (io) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { + return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg); + } + } } PUSHs(boolSV(do_close(gv, TRUE))); RETURN; @@ -684,14 +684,14 @@ PP(pp_pipe_op) rstio = GvIOn(rgv); if (IoIFP(rstio)) - do_close(rgv, FALSE); + do_close(rgv, FALSE); wstio = GvIOn(wgv); if (IoIFP(wstio)) - do_close(wgv, FALSE); + do_close(wgv, FALSE); if (PerlProc_pipe_cloexec(fd) < 0) - goto badexit; + goto badexit; IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE); IoOFP(wstio) = PerlIO_fdopen(fd[1], "w" PIPE_OPEN_MODE); @@ -701,15 +701,15 @@ PP(pp_pipe_op) IoTYPE(wstio) = IoTYPE_WRONLY; if (!IoIFP(rstio) || !IoOFP(wstio)) { - if (IoIFP(rstio)) - PerlIO_close(IoIFP(rstio)); - else - PerlLIO_close(fd[0]); - if (IoOFP(wstio)) - PerlIO_close(IoOFP(wstio)); - else - PerlLIO_close(fd[1]); - goto badexit; + if (IoIFP(rstio)) + PerlIO_close(IoIFP(rstio)); + else + PerlLIO_close(fd[0]); + if (IoOFP(wstio)) + PerlIO_close(IoOFP(wstio)); + else + PerlLIO_close(fd[1]); + goto badexit; } RETPUSHYES; @@ -729,14 +729,14 @@ PP(pp_fileno) const MAGIC *mg; if (MAXARG < 1) - RETPUSHUNDEF; + RETPUSHUNDEF; gv = MUTABLE_GV(POPs); io = GvIO(gv); if (io - && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) + && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg); + return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg); } if (io && IoDIRP(io)) { @@ -756,12 +756,12 @@ PP(pp_fileno) } if (!io || !(fp = IoIFP(io))) { - /* Can't do this because people seem to do things like - defined(fileno($foo)) to check whether $foo is a valid fh. + /* Can't do this because people seem to do things like + defined(fileno($foo)) to check whether $foo is a valid fh. - report_evil_fh(gv); - */ - RETPUSHUNDEF; + report_evil_fh(gv); + */ + RETPUSHUNDEF; } PUSHi(PerlIO_fileno(fp)); @@ -776,15 +776,15 @@ PP(pp_umask) Mode_t anum; if (MAXARG < 1 || (!TOPs && !POPs)) { - anum = PerlLIO_umask(022); - /* setting it to 022 between the two calls to umask avoids - * to have a window where the umask is set to 0 -- meaning - * that another thread could create world-writeable files. */ - if (anum != 022) - (void)PerlLIO_umask(anum); + anum = PerlLIO_umask(022); + /* setting it to 022 between the two calls to umask avoids + * to have a window where the umask is set to 0 -- meaning + * that another thread could create world-writeable files. */ + if (anum != 022) + (void)PerlLIO_umask(anum); } else - anum = PerlLIO_umask(POPi); + anum = PerlLIO_umask(POPi); TAINT_PROPER("umask"); XPUSHi(anum); #else @@ -792,7 +792,7 @@ PP(pp_umask) * Otherwise it's harmless and more useful to just return undef * since 'group' and 'other' concepts probably don't exist here. */ if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700)) - DIE(aTHX_ "umask not implemented"); + DIE(aTHX_ "umask not implemented"); XPUSHs(&PL_sv_undef); #endif RETURN; @@ -807,55 +807,55 @@ PP(pp_binmode) SV *discp = NULL; if (MAXARG < 1) - RETPUSHUNDEF; + RETPUSHUNDEF; if (MAXARG > 1) { - discp = POPs; + discp = POPs; } gv = MUTABLE_GV(POPs); io = GvIO(gv); if (io) { - const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { - /* This takes advantage of the implementation of the varargs - function, which I don't think that the optimiser will be able to - figure out. Although, as it's a static function, in theory it - could. */ - return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg, - G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED, - discp ? 1 : 0, discp); - } + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { + /* This takes advantage of the implementation of the varargs + function, which I don't think that the optimiser will be able to + figure out. Although, as it's a static function, in theory it + could. */ + return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg, + G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED, + discp ? 1 : 0, discp); + } } if (!io || !(fp = IoIFP(io))) { - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; } PUTBACK; { - STRLEN len = 0; - const char *d = NULL; - int mode; - if (discp) - d = SvPV_const(discp, len); - mode = mode_from_discipline(d, len); - if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) { - if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { - if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) { - SPAGAIN; - RETPUSHUNDEF; - } - } - SPAGAIN; - RETPUSHYES; - } - else { - SPAGAIN; - RETPUSHUNDEF; - } + STRLEN len = 0; + const char *d = NULL; + int mode; + if (discp) + d = SvPV_const(discp, len); + mode = mode_from_discipline(d, len); + if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) { + if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { + if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) { + SPAGAIN; + RETPUSHUNDEF; + } + } + SPAGAIN; + RETPUSHYES; + } + else { + SPAGAIN; + RETPUSHUNDEF; + } } } @@ -872,66 +872,66 @@ PP(pp_tie) SV *varsv = *++MARK; switch(SvTYPE(varsv)) { - case SVt_PVHV: - { - HE *entry; - methname = "TIEHASH"; - if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) { - HvLAZYDEL_off(varsv); - hv_free_ent((HV *)varsv, entry); - } - HvEITER_set(MUTABLE_HV(varsv), 0); - break; - } - case SVt_PVAV: - methname = "TIEARRAY"; - if (!AvREAL(varsv)) { - if (!AvREIFY(varsv)) - Perl_croak(aTHX_ "Cannot tie unreifiable array"); - av_clear((AV *)varsv); - AvREIFY_off(varsv); - AvREAL_on(varsv); - } - break; - case SVt_PVGV: - case SVt_PVLV: - if (isGV_with_GP(varsv) && !SvFAKE(varsv)) { - methname = "TIEHANDLE"; - how = PERL_MAGIC_tiedscalar; - /* For tied filehandles, we apply tiedscalar magic to the IO - slot of the GP rather than the GV itself. AMS 20010812 */ - if (!GvIOp(varsv)) - GvIOp(varsv) = newIO(); - varsv = MUTABLE_SV(GvIOp(varsv)); - break; - } - if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') { - vivify_defelem(varsv); - varsv = LvTARG(varsv); - } - /* FALLTHROUGH */ - default: - methname = "TIESCALAR"; - how = PERL_MAGIC_tiedscalar; - break; + case SVt_PVHV: + { + HE *entry; + methname = "TIEHASH"; + if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) { + HvLAZYDEL_off(varsv); + hv_free_ent((HV *)varsv, entry); + } + HvEITER_set(MUTABLE_HV(varsv), 0); + break; + } + case SVt_PVAV: + methname = "TIEARRAY"; + if (!AvREAL(varsv)) { + if (!AvREIFY(varsv)) + Perl_croak(aTHX_ "Cannot tie unreifiable array"); + av_clear((AV *)varsv); + AvREIFY_off(varsv); + AvREAL_on(varsv); + } + break; + case SVt_PVGV: + case SVt_PVLV: + if (isGV_with_GP(varsv) && !SvFAKE(varsv)) { + methname = "TIEHANDLE"; + how = PERL_MAGIC_tiedscalar; + /* For tied filehandles, we apply tiedscalar magic to the IO + slot of the GP rather than the GV itself. AMS 20010812 */ + if (!GvIOp(varsv)) + GvIOp(varsv) = newIO(); + varsv = MUTABLE_SV(GvIOp(varsv)); + break; + } + if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') { + vivify_defelem(varsv); + varsv = LvTARG(varsv); + } + /* FALLTHROUGH */ + default: + methname = "TIESCALAR"; + how = PERL_MAGIC_tiedscalar; + break; } items = SP - MARK++; if (sv_isobject(*MARK)) { /* Calls GET magic. */ - ENTER_with_name("call_TIE"); - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP,(I32)items); - while (items--) - PUSHs(*MARK++); - PUTBACK; - call_method(methname, G_SCALAR); + ENTER_with_name("call_TIE"); + PUSHSTACKi(PERLSI_MAGIC); + PUSHMARK(SP); + EXTEND(SP,(I32)items); + while (items--) + PUSHs(*MARK++); + PUTBACK; + call_method(methname, G_SCALAR); } else { - /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO" - * will attempt to invoke IO::File::TIEARRAY, with (best case) the - * wrong error message, and worse case, supreme action at a distance. - * (Sorry obfuscation writers. You're not going to be given this one.) - */ + /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO" + * will attempt to invoke IO::File::TIEARRAY, with (best case) the + * wrong error message, and worse case, supreme action at a distance. + * (Sorry obfuscation writers. You're not going to be given this one.) + */ stash = gv_stashsv(*MARK, 0); if (!stash) { if (SvROK(*MARK)) @@ -963,28 +963,28 @@ PP(pp_tie) DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"", methname, HvENAME_HEK_NN(stash)); } - ENTER_with_name("call_TIE"); - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP,(I32)items); - while (items--) - PUSHs(*MARK++); - PUTBACK; - call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); + ENTER_with_name("call_TIE"); + PUSHSTACKi(PERLSI_MAGIC); + PUSHMARK(SP); + EXTEND(SP,(I32)items); + while (items--) + PUSHs(*MARK++); + PUTBACK; + call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); } SPAGAIN; sv = TOPs; POPSTACK; if (sv_isobject(sv)) { - sv_unmagic(varsv, how); - /* Croak if a self-tie on an aggregate is attempted. */ - if (varsv == SvRV(sv) && - (SvTYPE(varsv) == SVt_PVAV || - SvTYPE(varsv) == SVt_PVHV)) - Perl_croak(aTHX_ - "Self-ties of arrays and hashes are not supported"); - sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0); + sv_unmagic(varsv, how); + /* Croak if a self-tie on an aggregate is attempted. */ + if (varsv == SvRV(sv) && + (SvTYPE(varsv) == SVt_PVAV || + SvTYPE(varsv) == SVt_PVHV)) + Perl_croak(aTHX_ + "Self-ties of arrays and hashes are not supported"); + sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0); } LEAVE_with_name("call_TIE"); SP = PL_stack_base + markoff; @@ -1001,34 +1001,34 @@ PP(pp_untie) MAGIC *mg; SV *sv = POPs; const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) - ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; + ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) - RETPUSHYES; + RETPUSHYES; if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' && - !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF; + !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF; if ((mg = SvTIED_mg(sv, how))) { - SV * const obj = SvRV(SvTIED_obj(sv, mg)); + SV * const obj = SvRV(SvTIED_obj(sv, mg)); if (obj && SvSTASH(obj)) { - GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE); - CV *cv; - if (gv && isGV(gv) && (cv = GvCV(gv))) { - PUSHMARK(SP); - PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg)); - mXPUSHi(SvREFCNT(obj) - 1); - PUTBACK; - ENTER_with_name("call_UNTIE"); - call_sv(MUTABLE_SV(cv), G_VOID); - LEAVE_with_name("call_UNTIE"); - SPAGAIN; + GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE); + CV *cv; + if (gv && isGV(gv) && (cv = GvCV(gv))) { + PUSHMARK(SP); + PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg)); + mXPUSHi(SvREFCNT(obj) - 1); + PUTBACK; + ENTER_with_name("call_UNTIE"); + call_sv(MUTABLE_SV(cv), G_VOID); + LEAVE_with_name("call_UNTIE"); + SPAGAIN; + } + else if (mg && SvREFCNT(obj) > 1) { + Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE), + "untie attempted while %" UVuf " inner references still exist", + (UV)SvREFCNT(obj) - 1 ) ; } - else if (mg && SvREFCNT(obj) > 1) { - Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE), - "untie attempted while %" UVuf " inner references still exist", - (UV)SvREFCNT(obj) - 1 ) ; - } } } sv_unmagic(sv, how) ; @@ -1041,17 +1041,17 @@ PP(pp_tied) const MAGIC *mg; dTOPss; const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) - ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; + ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) - goto ret_undef; + goto ret_undef; if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' && - !(sv = defelem_target(sv, NULL))) goto ret_undef; + !(sv = defelem_target(sv, NULL))) goto ret_undef; if ((mg = SvTIED_mg(sv, how))) { - SETs(SvTIED_obj(sv, mg)); - return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */ + SETs(SvTIED_obj(sv, mg)); + return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */ } ret_undef: SETs(&PL_sv_undef); @@ -1069,11 +1069,11 @@ PP(pp_dbmopen) SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP); stash = gv_stashsv(sv, 0); if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) { - PUTBACK; - require_pv("AnyDBM_File.pm"); - SPAGAIN; - if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) - DIE(aTHX_ "No dbm on this machine"); + PUTBACK; + require_pv("AnyDBM_File.pm"); + SPAGAIN; + if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) + DIE(aTHX_ "No dbm on this machine"); } ENTER; @@ -1083,11 +1083,11 @@ PP(pp_dbmopen) PUSHs(sv); PUSHs(left); if (SvIV(right)) - mPUSHu(O_RDWR|O_CREAT); + mPUSHu(O_RDWR|O_CREAT); else { - mPUSHu(O_RDWR); - if (!SvOK(right)) right = &PL_sv_no; + mPUSHu(O_RDWR); + if (!SvOK(right)) right = &PL_sv_no; } PUSHs(right); PUTBACK; @@ -1095,22 +1095,22 @@ PP(pp_dbmopen) SPAGAIN; if (!sv_isobject(TOPs)) { - SP--; - PUSHMARK(SP); - PUSHs(sv); - PUSHs(left); - mPUSHu(O_RDONLY); - PUSHs(right); - PUTBACK; - call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); - SPAGAIN; + SP--; + PUSHMARK(SP); + PUSHs(sv); + PUSHs(left); + mPUSHu(O_RDONLY); + PUSHs(right); + PUTBACK; + call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); + SPAGAIN; if (sv_isobject(TOPs)) goto retie; } else { retie: - sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied); - sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0); + sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied); + sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0); } LEAVE; RETURN; @@ -1133,9 +1133,9 @@ PP(pp_sselect) char *fd_sets[4]; SV *svs[4]; #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 - I32 masksize; - I32 offset; - I32 k; + I32 masksize; + I32 offset; + I32 k; # if BYTEORDER & 0xf0000 # define ORDERBYTE (0x88888888 - BYTEORDER) @@ -1147,29 +1147,29 @@ PP(pp_sselect) SP -= 4; for (i = 1; i <= 3; i++) { - SV * const sv = svs[i] = SP[i]; - SvGETMAGIC(sv); - if (!SvOK(sv)) - continue; - if (SvREADONLY(sv)) { - if (!(SvPOK(sv) && SvCUR(sv) == 0)) - Perl_croak_no_modify(); - } - else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); - if (!SvPOK(sv)) { - if (!SvPOKp(sv)) - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), - "Non-string passed as bitmask"); - if (SvGAMAGIC(sv)) { - svs[i] = sv_newmortal(); - sv_copypv_nomg(svs[i], sv); - } - else - SvPV_force_nomg_nolen(sv); /* force string conversion */ - } - j = SvCUR(svs[i]); - if (maxlen < j) - maxlen = j; + SV * const sv = svs[i] = SP[i]; + SvGETMAGIC(sv); + if (!SvOK(sv)) + continue; + if (SvREADONLY(sv)) { + if (!(SvPOK(sv) && SvCUR(sv) == 0)) + Perl_croak_no_modify(); + } + else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); + if (!SvPOK(sv)) { + if (!SvPOKp(sv)) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Non-string passed as bitmask"); + if (SvGAMAGIC(sv)) { + svs[i] = sv_newmortal(); + sv_copypv_nomg(svs[i], sv); + } + else + SvPV_force_nomg_nolen(sv); /* force string conversion */ + } + j = SvCUR(svs[i]); + if (maxlen < j) + maxlen = j; } /* little endians can use vecs directly */ @@ -1205,42 +1205,42 @@ PP(pp_sselect) sv = SP[4]; SvGETMAGIC(sv); if (SvOK(sv)) { - value = SvNV_nomg(sv); - if (value < 0.0) - value = 0.0; - timebuf.tv_sec = (long)value; - value -= (NV)timebuf.tv_sec; - timebuf.tv_usec = (long)(value * 1000000.0); + value = SvNV_nomg(sv); + if (value < 0.0) + value = 0.0; + timebuf.tv_sec = (long)value; + value -= (NV)timebuf.tv_sec; + timebuf.tv_usec = (long)(value * 1000000.0); } else - tbuf = NULL; + tbuf = NULL; for (i = 1; i <= 3; i++) { - sv = svs[i]; - if (!SvOK(sv) || SvCUR(sv) == 0) { - fd_sets[i] = 0; - continue; - } - assert(SvPOK(sv)); - j = SvLEN(sv); - if (j < growsize) { - Sv_Grow(sv, growsize); - } - j = SvCUR(sv); - s = SvPVX(sv) + j; - while (++j <= growsize) { - *s++ = '\0'; - } + sv = svs[i]; + if (!SvOK(sv) || SvCUR(sv) == 0) { + fd_sets[i] = 0; + continue; + } + assert(SvPOK(sv)); + j = SvLEN(sv); + if (j < growsize) { + Sv_Grow(sv, growsize); + } + j = SvCUR(sv); + s = SvPVX(sv) + j; + while (++j <= growsize) { + *s++ = '\0'; + } #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 - s = SvPVX(sv); - Newx(fd_sets[i], growsize, char); - for (offset = 0; offset < growsize; offset += masksize) { - for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) - fd_sets[i][j+offset] = s[(k % masksize) + offset]; - } + s = SvPVX(sv); + Newx(fd_sets[i], growsize, char); + for (offset = 0; offset < growsize; offset += masksize) { + for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) + fd_sets[i][j+offset] = s[(k % masksize) + offset]; + } #else - fd_sets[i] = SvPVX(sv); + fd_sets[i] = SvPVX(sv); #endif } @@ -1248,42 +1248,42 @@ PP(pp_sselect) /* Can't make just the (void*) conditional because that would be * cpp #if within cpp macro, and not all compilers like that. */ nfound = PerlSock_select( - maxlen * 8, - (Select_fd_set_t) fd_sets[1], - (Select_fd_set_t) fd_sets[2], - (Select_fd_set_t) fd_sets[3], - (void*) tbuf); /* Workaround for compiler bug. */ + maxlen * 8, + (Select_fd_set_t) fd_sets[1], + (Select_fd_set_t) fd_sets[2], + (Select_fd_set_t) fd_sets[3], + (void*) tbuf); /* Workaround for compiler bug. */ #else nfound = PerlSock_select( - maxlen * 8, - (Select_fd_set_t) fd_sets[1], - (Select_fd_set_t) fd_sets[2], - (Select_fd_set_t) fd_sets[3], - tbuf); + maxlen * 8, + (Select_fd_set_t) fd_sets[1], + (Select_fd_set_t) fd_sets[2], + (Select_fd_set_t) fd_sets[3], + tbuf); #endif for (i = 1; i <= 3; i++) { - if (fd_sets[i]) { - sv = svs[i]; + if (fd_sets[i]) { + sv = svs[i]; #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 - s = SvPVX(sv); - for (offset = 0; offset < growsize; offset += masksize) { - for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) - s[(k % masksize) + offset] = fd_sets[i][j+offset]; - } - Safefree(fd_sets[i]); + s = SvPVX(sv); + for (offset = 0; offset < growsize; offset += masksize) { + for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4)) + s[(k % masksize) + offset] = fd_sets[i][j+offset]; + } + Safefree(fd_sets[i]); #endif - if (sv != SP[i]) - SvSetMagicSV(SP[i], sv); - else - SvSETMAGIC(sv); - } + if (sv != SP[i]) + SvSetMagicSV(SP[i], sv); + else + SvSETMAGIC(sv); + } } PUSHi(nfound); if (GIMME_V == G_ARRAY && tbuf) { - value = (NV)(timebuf.tv_sec) + - (NV)(timebuf.tv_usec) / 1000000.0; - mPUSHn(value); + value = (NV)(timebuf.tv_sec) + + (NV)(timebuf.tv_usec) / 1000000.0; + mPUSHn(value); } RETURN; #else @@ -1326,23 +1326,23 @@ PP(pp_select) GV * const *gvp; if (!egv) - egv = PL_defoutgv; + egv = PL_defoutgv; hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL; gvp = hv && HvENAME(hv) - ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE) - : NULL; + ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE) + : NULL; if (gvp && *gvp == egv) { - gv_efullname4(TARG, PL_defoutgv, NULL, TRUE); - XPUSHTARG; + gv_efullname4(TARG, PL_defoutgv, NULL, TRUE); + XPUSHTARG; } else { - mXPUSHs(newRV(MUTABLE_SV(egv))); + mXPUSHs(newRV(MUTABLE_SV(egv))); } if (newdefout) { - if (!GvIO(newdefout)) - gv_IOadd(newdefout); - setdefout(newdefout); + if (!GvIO(newdefout)) + gv_IOadd(newdefout); + setdefout(newdefout); } RETURN; @@ -1354,42 +1354,42 @@ PP(pp_getc) /* pp_coreargs pushes a NULL to indicate no args passed to * CORE::getc() */ GV * const gv = - MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs); + MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs); IO *const io = GvIO(gv); if (MAXARG == 0) - EXTEND(SP, 1); + EXTEND(SP, 1); if (io) { - const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { - const U8 gimme = GIMME_V; - Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0); - if (gimme == G_SCALAR) { - SPAGAIN; - SvSetMagicSV_nosteal(TARG, TOPs); - } - return NORMAL; - } + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { + const U8 gimme = GIMME_V; + Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0); + if (gimme == G_SCALAR) { + SPAGAIN; + SvSetMagicSV_nosteal(TARG, TOPs); + } + return NORMAL; + } } if (!gv || do_eof(gv)) { /* make sure we have fp with something */ - if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)) - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); - RETPUSHUNDEF; + if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY)) + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + RETPUSHUNDEF; } TAINT; sv_setpvs(TARG, " "); *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */ if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) { - /* Find out how many bytes the char needs */ - Size_t len = UTF8SKIP(SvPVX_const(TARG)); - if (len > 1) { - SvGROW(TARG,len+1); - len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1); - SvCUR_set(TARG,1+len); - } - SvUTF8_on(TARG); + /* Find out how many bytes the char needs */ + Size_t len = UTF8SKIP(SvPVX_const(TARG)); + if (len > 1) { + SvGROW(TARG,len+1); + len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1); + SvCUR_set(TARG,1+len); + } + SvUTF8_on(TARG); } else SvUTF8_off(TARG); PUSHTARG; @@ -1405,12 +1405,12 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PERL_ARGS_ASSERT_DOFORM; if (CvCLONE(cv)) - cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); + cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix); cx_pushformat(cx, cv, retop, gv); if (CvDEPTH(cv) >= 2) - pad_push(CvPADLIST(cv), CvDEPTH(cv)); + pad_push(CvPADLIST(cv), CvDEPTH(cv)); PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); setdefout(gv); /* locally select filehandle so $% et al work */ @@ -1426,30 +1426,30 @@ PP(pp_enterwrite) CV *cv = NULL; if (MAXARG == 0) { - EXTEND(SP, 1); - gv = PL_defoutgv; + EXTEND(SP, 1); + gv = PL_defoutgv; } else { - gv = MUTABLE_GV(POPs); - if (!gv) - gv = PL_defoutgv; + gv = MUTABLE_GV(POPs); + if (!gv) + gv = PL_defoutgv; } io = GvIO(gv); if (!io) { - RETPUSHNO; + RETPUSHNO; } if (IoFMT_GV(io)) - fgv = IoFMT_GV(io); + fgv = IoFMT_GV(io); else - fgv = gv; + fgv = gv; assert(fgv); cv = GvFORM(fgv); if (!cv) { SV * const tmpsv = sv_newmortal(); - gv_efullname4(tmpsv, fgv, NULL, FALSE); - DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv)); + gv_efullname4(tmpsv, fgv, NULL, FALSE); + DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv)); } IoFLAGS(io) &= ~IOf_DIDTOP; RETURNOP(doform(cv,gv,PL_op->op_next)); @@ -1470,72 +1470,72 @@ PP(pp_leavewrite) goto forget_top; DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n", - (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget))); + (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget))); if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) && - PL_formtarget != PL_toptarget) + PL_formtarget != PL_toptarget) { - GV *fgv; - CV *cv; - if (!IoTOP_GV(io)) { - GV *topgv; - - if (!IoTOP_NAME(io)) { - SV *topname; - if (!IoFMT_NAME(io)) - IoFMT_NAME(io) = savepv(GvNAME(gv)); - topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP", + GV *fgv; + CV *cv; + if (!IoTOP_GV(io)) { + GV *topgv; + + if (!IoTOP_NAME(io)) { + SV *topname; + if (!IoFMT_NAME(io)) + IoFMT_NAME(io) = savepv(GvNAME(gv)); + topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP", HEKfARG(GvNAME_HEK(gv)))); - topgv = gv_fetchsv(topname, 0, SVt_PVFM); - if ((topgv && GvFORM(topgv)) || - !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM)) - IoTOP_NAME(io) = savesvpv(topname); - else - IoTOP_NAME(io) = savepvs("top"); - } - topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM); - if (!topgv || !GvFORM(topgv)) { - IoLINES_LEFT(io) = IoPAGE_LEN(io); - goto forget_top; - } - IoTOP_GV(io) = topgv; - } - if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */ - I32 lines = IoLINES_LEFT(io); - const char *s = SvPVX_const(PL_formtarget); + topgv = gv_fetchsv(topname, 0, SVt_PVFM); + if ((topgv && GvFORM(topgv)) || + !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM)) + IoTOP_NAME(io) = savesvpv(topname); + else + IoTOP_NAME(io) = savepvs("top"); + } + topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM); + if (!topgv || !GvFORM(topgv)) { + IoLINES_LEFT(io) = IoPAGE_LEN(io); + goto forget_top; + } + IoTOP_GV(io) = topgv; + } + if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */ + I32 lines = IoLINES_LEFT(io); + const char *s = SvPVX_const(PL_formtarget); const char *e = SvEND(PL_formtarget); - if (lines <= 0) /* Yow, header didn't even fit!!! */ - goto forget_top; - while (lines-- > 0) { - s = (char *) memchr(s, '\n', e - s); - if (!s) - break; - s++; - } - if (s) { - const STRLEN save = SvCUR(PL_formtarget); - SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget)); - do_print(PL_formtarget, ofp); - SvCUR_set(PL_formtarget, save); - sv_chop(PL_formtarget, s); - FmLINES(PL_formtarget) -= IoLINES_LEFT(io); - } - } - if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0) - do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp); - IoLINES_LEFT(io) = IoPAGE_LEN(io); - IoPAGE(io)++; - PL_formtarget = PL_toptarget; - IoFLAGS(io) |= IOf_DIDTOP; - fgv = IoTOP_GV(io); - assert(fgv); /* IoTOP_GV(io) should have been set above */ - cv = GvFORM(fgv); - if (!cv) { - SV * const sv = sv_newmortal(); - gv_efullname4(sv, fgv, NULL, FALSE); - DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv)); - } - return doform(cv, gv, PL_op); + if (lines <= 0) /* Yow, header didn't even fit!!! */ + goto forget_top; + while (lines-- > 0) { + s = (char *) memchr(s, '\n', e - s); + if (!s) + break; + s++; + } + if (s) { + const STRLEN save = SvCUR(PL_formtarget); + SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget)); + do_print(PL_formtarget, ofp); + SvCUR_set(PL_formtarget, save); + sv_chop(PL_formtarget, s); + FmLINES(PL_formtarget) -= IoLINES_LEFT(io); + } + } + if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0) + do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp); + IoLINES_LEFT(io) = IoPAGE_LEN(io); + IoPAGE(io)++; + PL_formtarget = PL_toptarget; + IoFLAGS(io) |= IOf_DIDTOP; + fgv = IoTOP_GV(io); + assert(fgv); /* IoTOP_GV(io) should have been set above */ + cv = GvFORM(fgv); + if (!cv) { + SV * const sv = sv_newmortal(); + gv_efullname4(sv, fgv, NULL, FALSE); + DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv)); + } + return doform(cv, gv, PL_op); } forget_top: @@ -1555,28 +1555,28 @@ PP(pp_leavewrite) * Currently we ignore any args to 'return' and just return * a single undef in both scalar and list contexts */ - PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); else if (!io || !(fp = IoOFP(io))) { - if (io && IoIFP(io)) - report_wrongway_fh(gv, '<'); - else - report_evil_fh(gv); - PUSHs(&PL_sv_no); + if (io && IoIFP(io)) + report_wrongway_fh(gv, '<'); + else + report_evil_fh(gv); + PUSHs(&PL_sv_no); } else { - if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) { - Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow"); - } - if (!do_print(PL_formtarget, fp)) - PUSHs(&PL_sv_no); - else { - FmLINES(PL_formtarget) = 0; - SvCUR_set(PL_formtarget, 0); - *SvEND(PL_formtarget) = '\0'; - if (IoFLAGS(io) & IOf_FLUSH) - (void)PerlIO_flush(fp); - PUSHs(&PL_sv_yes); - } + if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) { + Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow"); + } + if (!do_print(PL_formtarget, fp)) + PUSHs(&PL_sv_no); + else { + FmLINES(PL_formtarget) = 0; + SvCUR_set(PL_formtarget, 0); + *SvEND(PL_formtarget) = '\0'; + if (IoFLAGS(io) & IOf_FLUSH) + (void)PerlIO_flush(fp); + PUSHs(&PL_sv_yes); + } } PL_formtarget = PL_bodytarget; RETURNOP(retop); @@ -1588,50 +1588,50 @@ PP(pp_prtf) PerlIO *fp; GV * const gv - = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; + = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv; IO *const io = GvIO(gv); /* Treat empty list as "" */ if (MARK == SP) XPUSHs(&PL_sv_no); if (io) { - const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { - if (MARK == ORIGMARK) { - MEXTEND(SP, 1); - ++MARK; - Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); - ++SP; - } - return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io), - mg, - G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, - sp - mark); - } + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { + if (MARK == ORIGMARK) { + MEXTEND(SP, 1); + ++MARK; + Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); + ++SP; + } + return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io), + mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); + } } if (!io) { - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); - goto just_say_no; + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + goto just_say_no; } else if (!(fp = IoOFP(io))) { - if (IoIFP(io)) - report_wrongway_fh(gv, '<'); - else if (ckWARN(WARN_CLOSED)) - report_evil_fh(gv); - SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); - goto just_say_no; + if (IoIFP(io)) + report_wrongway_fh(gv, '<'); + else if (ckWARN(WARN_CLOSED)) + report_evil_fh(gv); + SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI); + goto just_say_no; } else { - SV *sv = sv_newmortal(); - do_sprintf(sv, SP - MARK, MARK + 1); - if (!do_print(sv, fp)) - goto just_say_no; + SV *sv = sv_newmortal(); + do_sprintf(sv, SP - MARK, MARK + 1); + if (!do_print(sv, fp)) + goto just_say_no; - if (IoFLAGS(io) & IOf_FLUSH) - if (PerlIO_flush(fp) == EOF) - goto just_say_no; + if (IoFLAGS(io) & IOf_FLUSH) + if (PerlIO_flush(fp) == EOF) + goto just_say_no; } SP = ORIGMARK; PUSHs(&PL_sv_yes); @@ -1655,11 +1655,11 @@ PP(pp_sysopen) /* Need TIEHANDLE method ? */ const char * const tmps = SvPV_const(sv, len); if (do_open_raw(gv, tmps, len, mode, perm, NULL)) { - IoLINES(GvIOp(gv)) = 0; - PUSHs(&PL_sv_yes); + IoLINES(GvIOp(gv)) = 0; + PUSHs(&PL_sv_yes); } else { - PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); } RETURN; } @@ -1690,34 +1690,34 @@ PP(pp_sysread) int fd; if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) - && gv && (io = GvIO(gv)) ) + && gv && (io = GvIO(gv)) ) { - const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { - return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg, - G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, - sp - mark); - } + const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { + return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); + } } if (!gv) - goto say_undef; + goto say_undef; bufsv = *++MARK; if (! SvOK(bufsv)) SvPVCLEAR(bufsv); length = SvIVx(*++MARK); if (length < 0) - DIE(aTHX_ "Negative length"); + DIE(aTHX_ "Negative length"); SETERRNO(0,0); if (MARK < SP) - offset = SvIVx(*++MARK); + offset = SvIVx(*++MARK); else - offset = 0; + offset = 0; io = GvIO(gv); if (!io || !IoIFP(io)) { - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); - goto say_undef; + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + goto say_undef; } /* Note that fd can here validly be -1, don't check it yet. */ @@ -1729,17 +1729,17 @@ PP(pp_sysread) "%s() isn't allowed on :utf8 handles", OP_DESC(PL_op)); } - buffer = SvPVutf8_force(bufsv, blen); - /* UTF-8 may not have been set if they are all low bytes */ - SvUTF8_on(bufsv); - buffer_utf8 = 0; + buffer = SvPVutf8_force(bufsv, blen); + /* UTF-8 may not have been set if they are all low bytes */ + SvUTF8_on(bufsv); + buffer_utf8 = 0; } else { - buffer = SvPV_force(bufsv, blen); - buffer_utf8 = DO_UTF8(bufsv); + buffer = SvPV_force(bufsv, blen); + buffer_utf8 = DO_UTF8(bufsv); } if (DO_UTF8(bufsv)) { - blen = sv_len_utf8_nomg(bufsv); + blen = sv_len_utf8_nomg(bufsv); } charstart = TRUE; @@ -1749,40 +1749,40 @@ PP(pp_sysread) #ifdef HAS_SOCKET if (PL_op->op_type == OP_RECV) { - Sock_size_t bufsize; - char namebuf[MAXPATHLEN]; + Sock_size_t bufsize; + char namebuf[MAXPATHLEN]; if (fd < 0) { SETERRNO(EBADF,SS_IVCHAN); goto say_undef; } #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) - bufsize = sizeof (struct sockaddr_in); + bufsize = sizeof (struct sockaddr_in); #else - bufsize = sizeof namebuf; + bufsize = sizeof namebuf; #endif #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */ - if (bufsize >= 256) - bufsize = 255; -#endif - buffer = SvGROW(bufsv, (STRLEN)(length+1)); - /* 'offset' means 'flags' here */ - count = PerlSock_recvfrom(fd, buffer, length, offset, - (struct sockaddr *)namebuf, &bufsize); - if (count < 0) + if (bufsize >= 256) + bufsize = 255; +#endif + buffer = SvGROW(bufsv, (STRLEN)(length+1)); + /* 'offset' means 'flags' here */ + count = PerlSock_recvfrom(fd, buffer, length, offset, + (struct sockaddr *)namebuf, &bufsize); + if (count < 0) goto say_undef; - /* MSG_TRUNC can give oversized count; quietly lose it */ - if (count > length) - count = length; - SvCUR_set(bufsv, count); - *SvEND(bufsv) = '\0'; - (void)SvPOK_only(bufsv); - if (fp_utf8) - SvUTF8_on(bufsv); - SvSETMAGIC(bufsv); - /* This should not be marked tainted if the fp is marked clean */ - if (!(IoFLAGS(io) & IOf_UNTAINT)) - SvTAINTED_on(bufsv); - SP = ORIGMARK; + /* MSG_TRUNC can give oversized count; quietly lose it */ + if (count > length) + count = length; + SvCUR_set(bufsv, count); + *SvEND(bufsv) = '\0'; + (void)SvPOK_only(bufsv); + if (fp_utf8) + SvUTF8_on(bufsv); + SvSETMAGIC(bufsv); + /* This should not be marked tainted if the fp is marked clean */ + if (!(IoFLAGS(io) & IOf_UNTAINT)) + SvTAINTED_on(bufsv); + SP = ORIGMARK; #if defined(__CYGWIN__) /* recvfrom() on cygwin doesn't set bufsize at all for connected sockets, leaving us with trash in the returned @@ -1791,22 +1791,22 @@ PP(pp_sysread) if (bufsize == sizeof namebuf) bufsize = 0; #endif - sv_setpvn(TARG, namebuf, bufsize); - PUSHs(TARG); - RETURN; + sv_setpvn(TARG, namebuf, bufsize); + PUSHs(TARG); + RETURN; } #endif if (offset < 0) { - if (-offset > (SSize_t)blen) - DIE(aTHX_ "Offset outside string"); - offset += blen; + if (-offset > (SSize_t)blen) + DIE(aTHX_ "Offset outside string"); + offset += blen; } if (DO_UTF8(bufsv)) { - /* convert offset-as-chars to offset-as-bytes */ - if (offset >= (SSize_t)blen) - offset += SvCUR(bufsv) - blen; - else - offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; + /* convert offset-as-chars to offset-as-bytes */ + if (offset >= (SSize_t)blen) + offset += SvCUR(bufsv) - blen; + else + offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; } more_bytes: @@ -1821,104 +1821,104 @@ PP(pp_sysread) IN_ENCODING Is true) */ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */ - Zero(buffer+orig_size, offset-orig_size, char); + Zero(buffer+orig_size, offset-orig_size, char); } buffer = buffer + offset; if (!buffer_utf8) { - read_target = bufsv; + read_target = bufsv; } else { - /* Best to read the bytes into a new SV, upgrade that to UTF8, then - concatenate it to the current buffer. */ + /* Best to read the bytes into a new SV, upgrade that to UTF8, then + concatenate it to the current buffer. */ - /* Truncate the existing buffer to the start of where we will be - reading to: */ - SvCUR_set(bufsv, offset); + /* Truncate the existing buffer to the start of where we will be + reading to: */ + SvCUR_set(bufsv, offset); - read_target = sv_newmortal(); - SvUPGRADE(read_target, SVt_PV); - buffer = SvGROW(read_target, (STRLEN)(length + 1)); + read_target = sv_newmortal(); + SvUPGRADE(read_target, SVt_PV); + buffer = SvGROW(read_target, (STRLEN)(length + 1)); } if (PL_op->op_type == OP_SYSREAD) { #ifdef PERL_SOCK_SYSREAD_IS_RECV - if (IoTYPE(io) == IoTYPE_SOCKET) { + if (IoTYPE(io) == IoTYPE_SOCKET) { if (fd < 0) { SETERRNO(EBADF,SS_IVCHAN); count = -1; } else count = PerlSock_recv(fd, buffer, length, 0); - } - else + } + else #endif - { + { if (fd < 0) { SETERRNO(EBADF,RMS_IFI); count = -1; } else count = PerlLIO_read(fd, buffer, length); - } + } } else { - count = PerlIO_read(IoIFP(io), buffer, length); - /* PerlIO_read() - like fread() returns 0 on both error and EOF */ - if (count == 0 && PerlIO_error(IoIFP(io))) - count = -1; + count = PerlIO_read(IoIFP(io), buffer, length); + /* PerlIO_read() - like fread() returns 0 on both error and EOF */ + if (count == 0 && PerlIO_error(IoIFP(io))) + count = -1; } if (count < 0) { - if (IoTYPE(io) == IoTYPE_WRONLY) - report_wrongway_fh(gv, '>'); - goto say_undef; + if (IoTYPE(io) == IoTYPE_WRONLY) + report_wrongway_fh(gv, '>'); + goto say_undef; } SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target))); *SvEND(read_target) = '\0'; (void)SvPOK_only(read_target); if (fp_utf8 && !IN_BYTES) { - /* Look at utf8 we got back and count the characters */ - const char *bend = buffer + count; - while (buffer < bend) { - if (charstart) { - skip = UTF8SKIP(buffer); - charskip = 0; - } - if (buffer - charskip + skip > bend) { - /* partial character - try for rest of it */ - length = skip - (bend-buffer); - offset = bend - SvPVX_const(bufsv); - charstart = FALSE; - charskip += count; - goto more_bytes; - } - else { - got++; - buffer += skip; - charstart = TRUE; - charskip = 0; - } + /* Look at utf8 we got back and count the characters */ + const char *bend = buffer + count; + while (buffer < bend) { + if (charstart) { + skip = UTF8SKIP(buffer); + charskip = 0; + } + if (buffer - charskip + skip > bend) { + /* partial character - try for rest of it */ + length = skip - (bend-buffer); + offset = bend - SvPVX_const(bufsv); + charstart = FALSE; + charskip += count; + goto more_bytes; + } + else { + got++; + buffer += skip; + charstart = TRUE; + charskip = 0; + } + } + /* If we have not 'got' the number of _characters_ we 'wanted' get some more + provided amount read (count) was what was requested (length) + */ + if (got < wanted && count == length) { + length = wanted - got; + offset = bend - SvPVX_const(bufsv); + goto more_bytes; } - /* If we have not 'got' the number of _characters_ we 'wanted' get some more - provided amount read (count) was what was requested (length) - */ - if (got < wanted && count == length) { - length = wanted - got; - offset = bend - SvPVX_const(bufsv); - goto more_bytes; - } - /* return value is character count */ - count = got; - SvUTF8_on(bufsv); + /* return value is character count */ + count = got; + SvUTF8_on(bufsv); } else if (buffer_utf8) { - /* Let svcatsv upgrade the bytes we read in to utf8. - The buffer is a mortal so will be freed soon. */ - sv_catsv_nomg(bufsv, read_target); + /* Let svcatsv upgrade the bytes we read in to utf8. + The buffer is a mortal so will be freed soon. */ + sv_catsv_nomg(bufsv, read_target); } SvSETMAGIC(bufsv); /* This should not be marked tainted if the fp is marked clean */ if (!(IoFLAGS(io) & IOf_UNTAINT)) - SvTAINTED_on(bufsv); + SvTAINTED_on(bufsv); SP = ORIGMARK; PUSHi(count); RETURN; @@ -1946,33 +1946,33 @@ PP(pp_syswrite) int fd; if (op_type == OP_SYSWRITE && io) { - const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { - if (MARK == SP - 1) { - SV *sv = *SP; - mXPUSHi(sv_len(sv)); - PUTBACK; - } - - return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg, - G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, - sp - mark); - } + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { + if (MARK == SP - 1) { + SV *sv = *SP; + mXPUSHi(sv_len(sv)); + PUTBACK; + } + + return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); + } } if (!gv) - goto say_undef; + goto say_undef; bufsv = *++MARK; SETERRNO(0,0); if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) { - retval = -1; - if (io && IoIFP(io)) - report_wrongway_fh(gv, '<'); - else - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); - goto say_undef; + retval = -1; + if (io && IoIFP(io)) + report_wrongway_fh(gv, '<'); + else + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + goto say_undef; } fd = PerlIO_fileno(IoIFP(io)); if (fd < 0) { @@ -1991,84 +1991,84 @@ PP(pp_syswrite) OP_DESC(PL_op)); } else if (doing_utf8) { - STRLEN tmplen = blen; - U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8); - if (!doing_utf8) { - tmpbuf = result; - buffer = (char *) tmpbuf; - blen = tmplen; - } - else { - assert((char *)result == buffer); - Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op)); - } + STRLEN tmplen = blen; + U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8); + if (!doing_utf8) { + tmpbuf = result; + buffer = (char *) tmpbuf; + blen = tmplen; + } + else { + assert((char *)result == buffer); + Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op)); + } } #ifdef HAS_SOCKET if (op_type == OP_SEND) { - const int flags = SvIVx(*++MARK); - if (SP > MARK) { - STRLEN mlen; - char * const sockbuf = SvPVx(*++MARK, mlen); - retval = PerlSock_sendto(fd, buffer, blen, - flags, (struct sockaddr *)sockbuf, mlen); - } - else { - retval = PerlSock_send(fd, buffer, blen, flags); - } + const int flags = SvIVx(*++MARK); + if (SP > MARK) { + STRLEN mlen; + char * const sockbuf = SvPVx(*++MARK, mlen); + retval = PerlSock_sendto(fd, buffer, blen, + flags, (struct sockaddr *)sockbuf, mlen); + } + else { + retval = PerlSock_send(fd, buffer, blen, flags); + } } else #endif { - Size_t length = 0; /* This length is in characters. */ - IV offset; + Size_t length = 0; /* This length is in characters. */ + IV offset; - if (MARK >= SP) { - length = blen; - } else { + if (MARK >= SP) { + length = blen; + } else { #if Size_t_size > IVSIZE - length = (Size_t)SvNVx(*++MARK); + length = (Size_t)SvNVx(*++MARK); #else - length = (Size_t)SvIVx(*++MARK); -#endif - if ((SSize_t)length < 0) { - Safefree(tmpbuf); - DIE(aTHX_ "Negative length"); - } - } - - if (MARK < SP) { - offset = SvIVx(*++MARK); - if (offset < 0) { - if (-offset > (IV)blen) { - Safefree(tmpbuf); - DIE(aTHX_ "Offset outside string"); - } - offset += blen; - } else if (offset > (IV)blen) { - Safefree(tmpbuf); - DIE(aTHX_ "Offset outside string"); - } - } else - offset = 0; - if (length > blen - offset) - length = blen - offset; + length = (Size_t)SvIVx(*++MARK); +#endif + if ((SSize_t)length < 0) { + Safefree(tmpbuf); + DIE(aTHX_ "Negative length"); + } + } + + if (MARK < SP) { + offset = SvIVx(*++MARK); + if (offset < 0) { + if (-offset > (IV)blen) { + Safefree(tmpbuf); + DIE(aTHX_ "Offset outside string"); + } + offset += blen; + } else if (offset > (IV)blen) { + Safefree(tmpbuf); + DIE(aTHX_ "Offset outside string"); + } + } else + offset = 0; + if (length > blen - offset) + length = blen - offset; buffer = buffer+offset; #ifdef PERL_SOCK_SYSWRITE_IS_SEND - if (IoTYPE(io) == IoTYPE_SOCKET) { - retval = PerlSock_send(fd, buffer, length, 0); - } - else + if (IoTYPE(io) == IoTYPE_SOCKET) { + retval = PerlSock_send(fd, buffer, length, 0); + } + else #endif - { - /* See the note at doio.c:do_print about filesize limits. --jhi */ + { + /* See the note at doio.c:do_print about filesize limits. --jhi */ retval = PerlLIO_write(fd, buffer, length); - } + } } if (retval < 0) - goto say_undef; + goto say_undef; SP = ORIGMARK; Safefree(tmpbuf); @@ -2104,48 +2104,48 @@ PP(pp_eof) unsigned int which; if (MAXARG) { - gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */ - which = 1; + gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */ + which = 1; } else { - EXTEND(SP, 1); + EXTEND(SP, 1); - if (PL_op->op_flags & OPf_SPECIAL) { - gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */ - which = 2; - } - else { - gv = PL_last_in_gv; /* eof */ - which = 0; - } + if (PL_op->op_flags & OPf_SPECIAL) { + gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */ + which = 2; + } + else { + gv = PL_last_in_gv; /* eof */ + which = 0; + } } if (!gv) - RETPUSHYES; + RETPUSHYES; if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which)); + return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which)); } if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ - if (io && !IoIFP(io)) { - if ((IoFLAGS(io) & IOf_START) && av_count(GvAVn(gv)) == 0) { - SV ** svp; - IoLINES(io) = 0; - IoFLAGS(io) &= ~IOf_START; - do_open6(gv, "-", 1, NULL, NULL, 0); - svp = &GvSV(gv); - if (*svp) { - SV * sv = *svp; - sv_setpvs(sv, "-"); - SvSETMAGIC(sv); - } - else - *svp = newSVpvs("-"); - } - else if (!nextargv(gv, FALSE)) - RETPUSHYES; - } + if (io && !IoIFP(io)) { + if ((IoFLAGS(io) & IOf_START) && av_count(GvAVn(gv)) == 0) { + SV ** svp; + IoLINES(io) = 0; + IoFLAGS(io) &= ~IOf_START; + do_open6(gv, "-", 1, NULL, NULL, 0); + svp = &GvSV(gv); + if (*svp) { + SV * sv = *svp; + sv_setpvs(sv, "-"); + SvSETMAGIC(sv); + } + else + *svp = newSVpvs("-"); + } + else if (!nextargv(gv, FALSE)) + RETPUSHYES; + } } PUSHs(boolSV(do_eof(gv))); @@ -2159,23 +2159,23 @@ PP(pp_tell) IO *io; if (MAXARG != 0 && (TOPs || POPs)) - PL_last_in_gv = MUTABLE_GV(POPs); + PL_last_in_gv = MUTABLE_GV(POPs); else - EXTEND(SP, 1); + EXTEND(SP, 1); gv = PL_last_in_gv; io = GvIO(gv); if (io) { - const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { - return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg); - } + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { + return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg); + } } else if (!gv) { - if (!errno) - SETERRNO(EBADF,RMS_IFI); - PUSHi(-1); - RETURN; + if (!errno) + SETERRNO(EBADF,RMS_IFI); + PUSHi(-1); + RETURN; } #if LSEEKSIZE > IVSIZE @@ -2203,23 +2203,23 @@ PP(pp_sysseek) IO *const io = GvIO(gv); if (io) { - const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); - if (mg) { + const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); + if (mg) { #if LSEEKSIZE > IVSIZE - SV *const offset_sv = newSVnv((NV) offset); + SV *const offset_sv = newSVnv((NV) offset); #else - SV *const offset_sv = newSViv(offset); + SV *const offset_sv = newSViv(offset); #endif - return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv, - newSViv(whence)); - } + return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv, + newSViv(whence)); + } } if (PL_op->op_type == OP_SEEK) - PUSHs(boolSV(do_seek(gv, offset, whence))); + PUSHs(boolSV(do_seek(gv, offset, whence))); else { - const Off_t sought = do_sysseek(gv, offset, whence); + const Off_t sought = do_sysseek(gv, offset, whence); if (sought < 0) PUSHs(&PL_sv_undef); else { @@ -2256,25 +2256,25 @@ PP(pp_truncate) /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */ SETERRNO(0,0); { - SV * const sv = POPs; - int result = 1; - GV *tmpgv; - IO *io; - - if (PL_op->op_flags & OPf_SPECIAL - ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1) - : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) { - io = GvIO(tmpgv); - if (!io) - result = 0; - else { - PerlIO *fp; - do_ftruncate_io: - TAINT_PROPER("truncate"); - if (!(fp = IoIFP(io))) { - result = 0; - } - else { + SV * const sv = POPs; + int result = 1; + GV *tmpgv; + IO *io; + + if (PL_op->op_flags & OPf_SPECIAL + ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1) + : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) { + io = GvIO(tmpgv); + if (!io) + result = 0; + else { + PerlIO *fp; + do_ftruncate_io: + TAINT_PROPER("truncate"); + if (!(fp = IoIFP(io))) { + result = 0; + } + else { int fd = PerlIO_fileno(fp); if (fd < 0) { SETERRNO(EBADF,RMS_IFI); @@ -2293,21 +2293,21 @@ PP(pp_truncate) result = 0; } } - } - } - } - else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { - io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */ - goto do_ftruncate_io; - } - else { - const char * const name = SvPV_nomg_const_nolen(sv); - TAINT_PROPER("truncate"); + } + } + } + else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { + io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */ + goto do_ftruncate_io; + } + else { + const char * const name = SvPV_nomg_const_nolen(sv); + TAINT_PROPER("truncate"); #ifdef HAS_TRUNCATE - if (truncate(name, len) < 0) - result = 0; + if (truncate(name, len) < 0) + result = 0; #else - { + { int mode = O_RDWR; int tmpfd; @@ -2323,22 +2323,22 @@ PP(pp_truncate) #endif tmpfd = PerlLIO_open_cloexec(name, mode); - if (tmpfd < 0) { - result = 0; - } else { - if (my_chsize(tmpfd, len) < 0) - result = 0; - PerlLIO_close(tmpfd); - } - } + if (tmpfd < 0) { + result = 0; + } else { + if (my_chsize(tmpfd, len) < 0) + result = 0; + PerlLIO_close(tmpfd); + } + } #endif - } + } - if (result) - RETPUSHYES; - if (!errno) - SETERRNO(EBADF,RMS_IFI); - RETPUSHUNDEF; + if (result) + RETPUSHYES; + if (!errno) + SETERRNO(EBADF,RMS_IFI); + RETPUSHUNDEF; } } @@ -2357,26 +2357,26 @@ PP(pp_ioctl) IV retval; if (!IoIFP(io)) { - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); /* well, sort of... */ - RETPUSHUNDEF; + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); /* well, sort of... */ + RETPUSHUNDEF; } if (SvPOK(argsv) || !SvNIOK(argsv)) { - STRLEN len; - STRLEN need; - s = SvPV_force(argsv, len); - need = IOCPARM_LEN(func); - if (len < need) { - s = Sv_Grow(argsv, need + 1); - SvCUR_set(argsv, need); - } + STRLEN len; + STRLEN need; + s = SvPV_force(argsv, len); + need = IOCPARM_LEN(func); + if (len < need) { + s = Sv_Grow(argsv, need + 1); + SvCUR_set(argsv, need); + } - s[SvCUR(argsv)] = 17; /* a little sanity check here */ + s[SvCUR(argsv)] = 17; /* a little sanity check here */ } else { - retval = SvIV(argsv); - s = INT2PTR(char*,retval); /* ouch */ + retval = SvIV(argsv); + s = INT2PTR(char*,retval); /* ouch */ } optype = PL_op->op_type; @@ -2384,35 +2384,35 @@ PP(pp_ioctl) if (optype == OP_IOCTL) #ifdef HAS_IOCTL - retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s); + retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s); #else - DIE(aTHX_ "ioctl is not implemented"); + DIE(aTHX_ "ioctl is not implemented"); #endif else #ifndef HAS_FCNTL DIE(aTHX_ "fcntl is not implemented"); #elif defined(OS2) && defined(__EMX__) - retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); + retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); #else - retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); + retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); #endif #if defined(HAS_IOCTL) || defined(HAS_FCNTL) if (SvPOK(argsv)) { - if (s[SvCUR(argsv)] != 17) - DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument", - OP_NAME(PL_op)); - s[SvCUR(argsv)] = 0; /* put our null back */ - SvSETMAGIC(argsv); /* Assume it has changed */ + if (s[SvCUR(argsv)] != 17) + DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument", + OP_NAME(PL_op)); + s[SvCUR(argsv)] = 0; /* put our null back */ + SvSETMAGIC(argsv); /* Assume it has changed */ } if (retval == -1) - RETPUSHUNDEF; + RETPUSHUNDEF; if (retval != 0) { - PUSHi(retval); + PUSHi(retval); } else { - PUSHp(zero_but_true, ZBTLEN); + PUSHp(zero_but_true, ZBTLEN); } #endif RETURN; @@ -2430,13 +2430,13 @@ PP(pp_flock) /* XXX Looks to me like io is always NULL at this point */ if (fp) { - (void)PerlIO_flush(fp); - value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0); + (void)PerlIO_flush(fp); + value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0); } else { - report_evil_fh(gv); - value = 0; - SETERRNO(EBADF,RMS_IFI); + report_evil_fh(gv); + value = 0; + SETERRNO(EBADF,RMS_IFI); } PUSHi(value); RETURN; @@ -2460,21 +2460,21 @@ PP(pp_socket) int fd; if (IoIFP(io)) - do_close(gv, FALSE); + do_close(gv, FALSE); TAINT_PROPER("socket"); fd = PerlSock_socket_cloexec(domain, type, protocol); if (fd < 0) { - RETPUSHUNDEF; + RETPUSHUNDEF; } IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */ IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE); IoTYPE(io) = IoTYPE_SOCKET; if (!IoIFP(io) || !IoOFP(io)) { - if (IoIFP(io)) PerlIO_close(IoIFP(io)); - if (IoOFP(io)) PerlIO_close(IoOFP(io)); - if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd); - RETPUSHUNDEF; + if (IoIFP(io)) PerlIO_close(IoIFP(io)); + if (IoOFP(io)) PerlIO_close(IoOFP(io)); + if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd); + RETPUSHUNDEF; } RETPUSHYES; @@ -2496,13 +2496,13 @@ PP(pp_sockpair) IO * const io1 = GvIOn(gv1); if (IoIFP(io1)) - do_close(gv1, FALSE); + do_close(gv1, FALSE); if (IoIFP(io2)) - do_close(gv2, FALSE); + do_close(gv2, FALSE); TAINT_PROPER("socketpair"); if (PerlSock_socketpair_cloexec(domain, type, protocol, fd) < 0) - RETPUSHUNDEF; + RETPUSHUNDEF; IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE); IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE); IoTYPE(io1) = IoTYPE_SOCKET; @@ -2510,13 +2510,13 @@ PP(pp_sockpair) IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE); IoTYPE(io2) = IoTYPE_SOCKET; if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) { - if (IoIFP(io1)) PerlIO_close(IoIFP(io1)); - if (IoOFP(io1)) PerlIO_close(IoOFP(io1)); - if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]); - if (IoIFP(io2)) PerlIO_close(IoIFP(io2)); - if (IoOFP(io2)) PerlIO_close(IoOFP(io2)); - if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]); - RETPUSHUNDEF; + if (IoIFP(io1)) PerlIO_close(IoIFP(io1)); + if (IoOFP(io1)) PerlIO_close(IoOFP(io1)); + if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]); + if (IoIFP(io2)) PerlIO_close(IoIFP(io2)); + if (IoOFP(io2)) PerlIO_close(IoOFP(io2)); + if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]); + RETPUSHUNDEF; } RETPUSHYES; @@ -2542,7 +2542,7 @@ PP(pp_bind) int fd; if (!IoIFP(io)) - goto nuts; + goto nuts; fd = PerlIO_fileno(IoIFP(io)); if (fd < 0) goto nuts; @@ -2551,12 +2551,12 @@ PP(pp_bind) op_type = PL_op->op_type; TAINT_PROPER(PL_op_desc[op_type]); if ((op_type == OP_BIND - ? PerlSock_bind(fd, (struct sockaddr *)addr, len) - : PerlSock_connect(fd, (struct sockaddr *)addr, len)) - >= 0) - RETPUSHYES; + ? PerlSock_bind(fd, (struct sockaddr *)addr, len) + : PerlSock_connect(fd, (struct sockaddr *)addr, len)) + >= 0) + RETPUSHYES; else - RETPUSHUNDEF; + RETPUSHUNDEF; nuts: report_evil_fh(gv); @@ -2572,12 +2572,12 @@ PP(pp_listen) IO * const io = GvIOn(gv); if (!IoIFP(io)) - goto nuts; + goto nuts; if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) - RETPUSHYES; + RETPUSHYES; else - RETPUSHUNDEF; + RETPUSHUNDEF; nuts: report_evil_fh(gv); @@ -2601,33 +2601,33 @@ PP(pp_accept) IO * const gstio = GvIO(ggv); if (!gstio || !IoIFP(gstio)) - goto nuts; + goto nuts; nstio = GvIOn(ngv); fd = PerlSock_accept_cloexec(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len); #if defined(OEMVS) if (len == 0) { - /* Some platforms indicate zero length when an AF_UNIX client is - * not bound. Simulate a non-zero-length sockaddr structure in - * this case. */ - namebuf[0] = 0; /* sun_len */ - namebuf[1] = AF_UNIX; /* sun_family */ - len = 2; + /* Some platforms indicate zero length when an AF_UNIX client is + * not bound. Simulate a non-zero-length sockaddr structure in + * this case. */ + namebuf[0] = 0; /* sun_len */ + namebuf[1] = AF_UNIX; /* sun_family */ + len = 2; } #endif if (fd < 0) - goto badexit; + goto badexit; if (IoIFP(nstio)) - do_close(ngv, FALSE); + do_close(ngv, FALSE); IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE); IoTYPE(nstio) = IoTYPE_SOCKET; if (!IoIFP(nstio) || !IoOFP(nstio)) { - if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); - if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio)); - if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd); - goto badexit; + if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); + if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio)); + if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd); + goto badexit; } #ifdef __SCO_VERSION__ @@ -2654,7 +2654,7 @@ PP(pp_shutdown) IO * const io = GvIOn(gv); if (!IoIFP(io)) - goto nuts; + goto nuts; PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 ); RETURN; @@ -2681,47 +2681,47 @@ PP(pp_ssockopt) Sock_size_t len; if (!IoIFP(io)) - goto nuts; + goto nuts; fd = PerlIO_fileno(IoIFP(io)); if (fd < 0) goto nuts; switch (optype) { case OP_GSOCKOPT: - SvGROW(sv, 257); - (void)SvPOK_only(sv); - SvCUR_set(sv,256); - *SvEND(sv) ='\0'; - len = SvCUR(sv); - if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0) - goto nuts2; + SvGROW(sv, 257); + (void)SvPOK_only(sv); + SvCUR_set(sv,256); + *SvEND(sv) ='\0'; + len = SvCUR(sv); + if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0) + goto nuts2; #if defined(_AIX) /* XXX Configure test: does getsockopt set the length properly? */ if (len == 256) len = sizeof(int); #endif - SvCUR_set(sv, len); - *SvEND(sv) ='\0'; - PUSHs(sv); - break; + SvCUR_set(sv, len); + *SvEND(sv) ='\0'; + PUSHs(sv); + break; case OP_SSOCKOPT: { - const char *buf; - int aint; - if (SvPOKp(sv)) { - STRLEN l; - buf = SvPV_const(sv, l); - len = l; - } - else { - aint = (int)SvIV(sv); - buf = (const char *) &aint; - len = sizeof(int); - } - if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0) - goto nuts2; - PUSHs(&PL_sv_yes); - } - break; + const char *buf; + int aint; + if (SvPOKp(sv)) { + STRLEN l; + buf = SvPV_const(sv, l); + len = l; + } + else { + aint = (int)SvIV(sv); + buf = (const char *) &aint; + len = sizeof(int); + } + if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0) + goto nuts2; + PUSHs(&PL_sv_yes); + } + break; } RETURN; @@ -2747,7 +2747,7 @@ PP(pp_getpeername) int fd; if (!IoIFP(io)) - goto nuts; + goto nuts; #ifdef HAS_SOCKADDR_STORAGE len = sizeof(struct sockaddr_storage); @@ -2763,30 +2763,30 @@ PP(pp_getpeername) goto nuts; switch (optype) { case OP_GETSOCKNAME: - if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) - goto nuts2; - break; + if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) + goto nuts2; + break; case OP_GETPEERNAME: - if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) - goto nuts2; + if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) + goto nuts2; #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS) - { - static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; - /* If the call succeeded, make sure we don't have a zeroed port/addr */ - if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET && - !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere, - sizeof(u_short) + sizeof(struct in_addr))) { - goto nuts2; - } - } -#endif - break; + { + static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; + /* If the call succeeded, make sure we don't have a zeroed port/addr */ + if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET && + !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere, + sizeof(u_short) + sizeof(struct in_addr))) { + goto nuts2; + } + } +#endif + break; } #ifdef BOGUS_GETNAME_RETURN /* Interactive Unix, getpeername() and getsockname() does not return valid namelen */ if (len == BOGUS_GETNAME_RETURN) - len = sizeof(struct sockaddr); + len = sizeof(struct sockaddr); #endif SvCUR_set(sv, len); *SvEND(sv) ='\0'; @@ -2817,36 +2817,36 @@ PP(pp_stat) if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1) : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) { - if (PL_op->op_type == OP_LSTAT) { - if (gv != PL_defgv) { - do_fstat_warning_check: - Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "lstat() on filehandle%s%" SVf, - gv ? " " : "", - SVfARG(gv + if (PL_op->op_type == OP_LSTAT) { + if (gv != PL_defgv) { + do_fstat_warning_check: + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "lstat() on filehandle%s%" SVf, + gv ? " " : "", + SVfARG(gv ? sv_2mortal(newSVhek(GvENAME_HEK(gv))) : &PL_sv_no)); - } else if (PL_laststype != OP_LSTAT) - /* diag_listed_as: The stat preceding %s wasn't an lstat */ - Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); - } - - if (gv == PL_defgv) { - if (PL_laststatval < 0) - SETERRNO(EBADF,RMS_IFI); - } else { + } else if (PL_laststype != OP_LSTAT) + /* diag_listed_as: The stat preceding %s wasn't an lstat */ + Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); + } + + if (gv == PL_defgv) { + if (PL_laststatval < 0) + SETERRNO(EBADF,RMS_IFI); + } else { do_fstat_have_io: - PL_laststype = OP_STAT; - PL_statgv = gv ? gv : (GV *)io; + PL_laststype = OP_STAT; + PL_statgv = gv ? gv : (GV *)io; SvPVCLEAR(PL_statname); if(gv) { io = GvIO(gv); - } + } if (io) { if (IoIFP(io)) { int fd = PerlIO_fileno(IoIFP(io)); if (fd < 0) { - report_evil_fh(gv); + report_evil_fh(gv); PL_laststatval = -1; SETERRNO(EBADF,RMS_IFI); } else { @@ -2856,153 +2856,153 @@ PP(pp_stat) PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache); } else { - report_evil_fh(gv); + report_evil_fh(gv); PL_laststatval = -1; - SETERRNO(EBADF,RMS_IFI); + SETERRNO(EBADF,RMS_IFI); } } else { - report_evil_fh(gv); - PL_laststatval = -1; - SETERRNO(EBADF,RMS_IFI); - } + report_evil_fh(gv); + PL_laststatval = -1; + SETERRNO(EBADF,RMS_IFI); + } } - if (PL_laststatval < 0) { - max = 0; - } + if (PL_laststatval < 0) { + max = 0; + } } else { const char *file; const char *temp; STRLEN len; - if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { + if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { io = MUTABLE_IO(SvRV(sv)); if (PL_op->op_type == OP_LSTAT) goto do_fstat_warning_check; goto do_fstat_have_io; } - SvTAINTED_off(PL_statname); /* previous tainting irrelevant */ + SvTAINTED_off(PL_statname); /* previous tainting irrelevant */ temp = SvPV_nomg_const(sv, len); - sv_setpv(PL_statname, temp); - PL_statgv = NULL; - PL_laststype = PL_op->op_type; + sv_setpv(PL_statname, temp); + PL_statgv = NULL; + PL_laststype = PL_op->op_type; file = SvPV_nolen_const(PL_statname); if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) { PL_laststatval = -1; } - else if (PL_op->op_type == OP_LSTAT) - PL_laststatval = PerlLIO_lstat(file, &PL_statcache); - else - PL_laststatval = PerlLIO_stat(file, &PL_statcache); - if (PL_laststatval < 0) { - if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { + else if (PL_op->op_type == OP_LSTAT) + PL_laststatval = PerlLIO_lstat(file, &PL_statcache); + else + PL_laststatval = PerlLIO_stat(file, &PL_statcache); + if (PL_laststatval < 0) { + if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { /* PL_warn_nl is constant */ GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); - Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); GCC_DIAG_RESTORE_STMT; } - max = 0; - } + max = 0; + } } gimme = GIMME_V; if (gimme != G_ARRAY) { - if (gimme != G_VOID) - XPUSHs(boolSV(max)); - RETURN; + if (gimme != G_VOID) + XPUSHs(boolSV(max)); + RETURN; } if (max) { - EXTEND(SP, max); - EXTEND_MORTAL(max); - mPUSHi(PL_statcache.st_dev); - { - /* - * We try to represent st_ino as a native IV or UV where - * possible, but fall back to a decimal string where - * necessary. The code to generate these decimal strings - * is quite obtuse, because (a) we're portable to non-POSIX - * platforms where st_ino might be signed; (b) we didn't - * necessarily detect at Configure time whether st_ino is - * signed; (c) we're portable to non-POSIX platforms where - * ino_t isn't defined, so have no name for the type of - * st_ino; and (d) sprintf() doesn't necessarily support - * integers as large as st_ino. - */ - bool neg; - Stat_t s; - CLANG_DIAG_IGNORE_STMT(-Wtautological-compare); - GCC_DIAG_IGNORE_STMT(-Wtype-limits); - neg = PL_statcache.st_ino < 0; - GCC_DIAG_RESTORE_STMT; - CLANG_DIAG_RESTORE_STMT; - if (neg) { - s.st_ino = (IV)PL_statcache.st_ino; - if (LIKELY(s.st_ino == PL_statcache.st_ino)) { - mPUSHi(s.st_ino); - } else { - char buf[sizeof(s.st_ino)*3+1], *p; - s.st_ino = PL_statcache.st_ino; - for (p = buf + sizeof(buf); p != buf+1; ) { - Stat_t t; - t.st_ino = s.st_ino / 10; - *--p = '0' + (int)(t.st_ino*10 - s.st_ino); - s.st_ino = t.st_ino; - } - while (*p == '0') - p++; - *--p = '-'; - mPUSHp(p, buf+sizeof(buf) - p); - } - } else { - s.st_ino = (UV)PL_statcache.st_ino; - if (LIKELY(s.st_ino == PL_statcache.st_ino)) { - mPUSHu(s.st_ino); - } else { - char buf[sizeof(s.st_ino)*3], *p; - s.st_ino = PL_statcache.st_ino; - for (p = buf + sizeof(buf); p != buf; ) { - Stat_t t; - t.st_ino = s.st_ino / 10; - *--p = '0' + (int)(s.st_ino - t.st_ino*10); - s.st_ino = t.st_ino; - } - while (*p == '0') - p++; - mPUSHp(p, buf+sizeof(buf) - p); - } - } - } - mPUSHu(PL_statcache.st_mode); - mPUSHu(PL_statcache.st_nlink); - + EXTEND(SP, max); + EXTEND_MORTAL(max); + mPUSHi(PL_statcache.st_dev); + { + /* + * We try to represent st_ino as a native IV or UV where + * possible, but fall back to a decimal string where + * necessary. The code to generate these decimal strings + * is quite obtuse, because (a) we're portable to non-POSIX + * platforms where st_ino might be signed; (b) we didn't + * necessarily detect at Configure time whether st_ino is + * signed; (c) we're portable to non-POSIX platforms where + * ino_t isn't defined, so have no name for the type of + * st_ino; and (d) sprintf() doesn't necessarily support + * integers as large as st_ino. + */ + bool neg; + Stat_t s; + CLANG_DIAG_IGNORE_STMT(-Wtautological-compare); + GCC_DIAG_IGNORE_STMT(-Wtype-limits); + neg = PL_statcache.st_ino < 0; + GCC_DIAG_RESTORE_STMT; + CLANG_DIAG_RESTORE_STMT; + if (neg) { + s.st_ino = (IV)PL_statcache.st_ino; + if (LIKELY(s.st_ino == PL_statcache.st_ino)) { + mPUSHi(s.st_ino); + } else { + char buf[sizeof(s.st_ino)*3+1], *p; + s.st_ino = PL_statcache.st_ino; + for (p = buf + sizeof(buf); p != buf+1; ) { + Stat_t t; + t.st_ino = s.st_ino / 10; + *--p = '0' + (int)(t.st_ino*10 - s.st_ino); + s.st_ino = t.st_ino; + } + while (*p == '0') + p++; + *--p = '-'; + mPUSHp(p, buf+sizeof(buf) - p); + } + } else { + s.st_ino = (UV)PL_statcache.st_ino; + if (LIKELY(s.st_ino == PL_statcache.st_ino)) { + mPUSHu(s.st_ino); + } else { + char buf[sizeof(s.st_ino)*3], *p; + s.st_ino = PL_statcache.st_ino; + for (p = buf + sizeof(buf); p != buf; ) { + Stat_t t; + t.st_ino = s.st_ino / 10; + *--p = '0' + (int)(s.st_ino - t.st_ino*10); + s.st_ino = t.st_ino; + } + while (*p == '0') + p++; + mPUSHp(p, buf+sizeof(buf) - p); + } + } + } + mPUSHu(PL_statcache.st_mode); + mPUSHu(PL_statcache.st_nlink); + sv_setuid(PUSHmortal, PL_statcache.st_uid); sv_setgid(PUSHmortal, PL_statcache.st_gid); #ifdef USE_STAT_RDEV - mPUSHi(PL_statcache.st_rdev); + mPUSHi(PL_statcache.st_rdev); #else - PUSHs(newSVpvs_flags("", SVs_TEMP)); + PUSHs(newSVpvs_flags("", SVs_TEMP)); #endif #if Off_t_size > IVSIZE - mPUSHn(PL_statcache.st_size); + mPUSHn(PL_statcache.st_size); #else - mPUSHi(PL_statcache.st_size); + mPUSHi(PL_statcache.st_size); #endif #ifdef BIG_TIME - mPUSHn(PL_statcache.st_atime); - mPUSHn(PL_statcache.st_mtime); - mPUSHn(PL_statcache.st_ctime); + mPUSHn(PL_statcache.st_atime); + mPUSHn(PL_statcache.st_mtime); + mPUSHn(PL_statcache.st_ctime); #else - mPUSHi(PL_statcache.st_atime); - mPUSHi(PL_statcache.st_mtime); - mPUSHi(PL_statcache.st_ctime); + mPUSHi(PL_statcache.st_atime); + mPUSHi(PL_statcache.st_mtime); + mPUSHi(PL_statcache.st_ctime); #endif #ifdef USE_STAT_BLOCKS - mPUSHu(PL_statcache.st_blksize); - mPUSHu(PL_statcache.st_blocks); + mPUSHu(PL_statcache.st_blksize); + mPUSHu(PL_statcache.st_blocks); #else - PUSHs(newSVpvs_flags("", SVs_TEMP)); - PUSHs(newSVpvs_flags("", SVs_TEMP)); + PUSHs(newSVpvs_flags("", SVs_TEMP)); + PUSHs(newSVpvs_flags("", SVs_TEMP)); #endif } RETURN; @@ -3055,11 +3055,11 @@ S_ft_return_true(pTHX_ SV *ret) { #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes) #define tryAMAGICftest_MG(chr) STMT_START { \ - if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \ - && PL_op->op_flags & OPf_KIDS) { \ - OP *next = S_try_amagic_ftest(aTHX_ chr); \ - if (next) return next; \ - } \ + if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \ + && PL_op->op_flags & OPf_KIDS) { \ + OP *next = S_try_amagic_ftest(aTHX_ chr); \ + if (next) return next; \ + } \ } STMT_END STATIC OP * @@ -3071,15 +3071,15 @@ S_try_amagic_ftest(pTHX_ char chr) { if (SvAMAGIC(arg)) { - const char tmpchr = chr; - SV * const tmpsv = amagic_call(arg, - newSVpvn_flags(&tmpchr, 1, SVs_TEMP), - ftest_amg, AMGf_unary); + const char tmpchr = chr; + SV * const tmpsv = amagic_call(arg, + newSVpvn_flags(&tmpchr, 1, SVs_TEMP), + ftest_amg, AMGf_unary); - if (!tmpsv) - return NULL; + if (!tmpsv) + return NULL; - return SvTRUE(tmpsv) + return SvTRUE(tmpsv) ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv); } return NULL; @@ -3125,88 +3125,88 @@ PP(pp_ftrread) switch (PL_op->op_type) { case OP_FTRREAD: #if !(defined(HAS_ACCESS) && defined(R_OK)) - use_access = 0; + use_access = 0; #endif - break; + break; case OP_FTRWRITE: #if defined(HAS_ACCESS) && defined(W_OK) - access_mode = W_OK; + access_mode = W_OK; #else - use_access = 0; + use_access = 0; #endif - stat_mode = S_IWUSR; - break; + stat_mode = S_IWUSR; + break; case OP_FTREXEC: #if defined(HAS_ACCESS) && defined(X_OK) - access_mode = X_OK; + access_mode = X_OK; #else - use_access = 0; + use_access = 0; #endif - stat_mode = S_IXUSR; - break; + stat_mode = S_IXUSR; + break; case OP_FTEWRITE: #ifdef PERL_EFF_ACCESS - access_mode = W_OK; + access_mode = W_OK; #endif - stat_mode = S_IWUSR; - /* FALLTHROUGH */ + stat_mode = S_IWUSR; + /* FALLTHROUGH */ case OP_FTEREAD: #ifndef PERL_EFF_ACCESS - use_access = 0; + use_access = 0; #endif - effective = TRUE; - break; + effective = TRUE; + break; case OP_FTEEXEC: #ifdef PERL_EFF_ACCESS - access_mode = X_OK; + access_mode = X_OK; #else - use_access = 0; + use_access = 0; #endif - stat_mode = S_IXUSR; - effective = TRUE; - break; + stat_mode = S_IXUSR; + effective = TRUE; + break; } if (use_access) { #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) STRLEN len; - const char *name = SvPV(*PL_stack_sp, len); + const char *name = SvPV(*PL_stack_sp, len); if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) { result = -1; } - else if (effective) { + else if (effective) { # ifdef PERL_EFF_ACCESS - result = PERL_EFF_ACCESS(name, access_mode); + result = PERL_EFF_ACCESS(name, access_mode); # else - DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s", - OP_NAME(PL_op)); + DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s", + OP_NAME(PL_op)); # endif - } - else { + } + else { # ifdef HAS_ACCESS - result = access(name, access_mode); + result = access(name, access_mode); # else - DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op)); + DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op)); # endif - } - if (result == 0) - FT_RETURNYES; - if (result < 0) - FT_RETURNUNDEF; - FT_RETURNNO; + } + if (result == 0) + FT_RETURNYES; + if (result < 0) + FT_RETURNUNDEF; + FT_RETURNNO; #endif } result = my_stat_flags(0); if (result < 0) - FT_RETURNUNDEF; + FT_RETURNUNDEF; if (cando(stat_mode, effective, &PL_statcache)) - FT_RETURNYES; + FT_RETURNYES; FT_RETURNNO; } @@ -3230,36 +3230,36 @@ PP(pp_ftis) result = my_stat_flags(0); if (result < 0) - FT_RETURNUNDEF; + FT_RETURNUNDEF; if (op_type == OP_FTIS) - FT_RETURNYES; + FT_RETURNYES; { - /* You can't dTARGET inside OP_FTIS, because you'll get - "panic: pad_sv po" - the op is not flagged to have a target. */ - dTARGET; - switch (op_type) { - case OP_FTSIZE: + /* You can't dTARGET inside OP_FTIS, because you'll get + "panic: pad_sv po" - the op is not flagged to have a target. */ + dTARGET; + switch (op_type) { + case OP_FTSIZE: #if Off_t_size > IVSIZE - sv_setnv(TARG, (NV)PL_statcache.st_size); + sv_setnv(TARG, (NV)PL_statcache.st_size); #else - sv_setiv(TARG, (IV)PL_statcache.st_size); -#endif - break; - case OP_FTMTIME: - sv_setnv(TARG, - ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 ); - break; - case OP_FTATIME: - sv_setnv(TARG, - ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 ); - break; - case OP_FTCTIME: - sv_setnv(TARG, - ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 ); - break; - } - SvSETMAGIC(TARG); - return SvTRUE_nomg_NN(TARG) + sv_setiv(TARG, (IV)PL_statcache.st_size); +#endif + break; + case OP_FTMTIME: + sv_setnv(TARG, + ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 ); + break; + case OP_FTATIME: + sv_setnv(TARG, + ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 ); + break; + case OP_FTCTIME: + sv_setnv(TARG, + ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 ); + break; + } + SvSETMAGIC(TARG); + return SvTRUE_nomg_NN(TARG) ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG); } } @@ -3292,61 +3292,61 @@ PP(pp_ftrowned) result = my_stat_flags(0); if (result < 0) - FT_RETURNUNDEF; + FT_RETURNUNDEF; switch (PL_op->op_type) { case OP_FTROWNED: - if (PL_statcache.st_uid == PerlProc_getuid()) - FT_RETURNYES; - break; + if (PL_statcache.st_uid == PerlProc_getuid()) + FT_RETURNYES; + break; case OP_FTEOWNED: - if (PL_statcache.st_uid == PerlProc_geteuid()) - FT_RETURNYES; - break; + if (PL_statcache.st_uid == PerlProc_geteuid()) + FT_RETURNYES; + break; case OP_FTZERO: - if (PL_statcache.st_size == 0) - FT_RETURNYES; - break; + if (PL_statcache.st_size == 0) + FT_RETURNYES; + break; case OP_FTSOCK: - if (S_ISSOCK(PL_statcache.st_mode)) - FT_RETURNYES; - break; + if (S_ISSOCK(PL_statcache.st_mode)) + FT_RETURNYES; + break; case OP_FTCHR: - if (S_ISCHR(PL_statcache.st_mode)) - FT_RETURNYES; - break; + if (S_ISCHR(PL_statcache.st_mode)) + FT_RETURNYES; + break; case OP_FTBLK: - if (S_ISBLK(PL_statcache.st_mode)) - FT_RETURNYES; - break; + if (S_ISBLK(PL_statcache.st_mode)) + FT_RETURNYES; + break; case OP_FTFILE: - if (S_ISREG(PL_statcache.st_mode)) - FT_RETURNYES; - break; + if (S_ISREG(PL_statcache.st_mode)) + FT_RETURNYES; + break; case OP_FTDIR: - if (S_ISDIR(PL_statcache.st_mode)) - FT_RETURNYES; - break; + if (S_ISDIR(PL_statcache.st_mode)) + FT_RETURNYES; + break; case OP_FTPIPE: - if (S_ISFIFO(PL_statcache.st_mode)) - FT_RETURNYES; - break; + if (S_ISFIFO(PL_statcache.st_mode)) + FT_RETURNYES; + break; #ifdef S_ISUID case OP_FTSUID: - if (PL_statcache.st_mode & S_ISUID) - FT_RETURNYES; - break; + if (PL_statcache.st_mode & S_ISUID) + FT_RETURNYES; + break; #endif #ifdef S_ISGID case OP_FTSGID: - if (PL_statcache.st_mode & S_ISGID) - FT_RETURNYES; - break; + if (PL_statcache.st_mode & S_ISGID) + FT_RETURNYES; + break; #endif #ifdef S_ISVTX case OP_FTSVTX: - if (PL_statcache.st_mode & S_ISVTX) - FT_RETURNYES; - break; + if (PL_statcache.st_mode & S_ISVTX) + FT_RETURNYES; + break; #endif } FT_RETURNNO; @@ -3360,9 +3360,9 @@ PP(pp_ftlink) result = my_lstat_flags(0); if (result < 0) - FT_RETURNUNDEF; + FT_RETURNUNDEF; if (S_ISLNK(PL_statcache.st_mode)) - FT_RETURNYES; + FT_RETURNYES; FT_RETURNNO; } @@ -3377,27 +3377,27 @@ PP(pp_fttty) tryAMAGICftest_MG('t'); if (PL_op->op_flags & OPf_REF) - gv = cGVOP_gv; + gv = cGVOP_gv; else { SV *tmpsv = *PL_stack_sp; if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) { - name = SvPV_nomg(tmpsv, namelen); - gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO); + name = SvPV_nomg(tmpsv, namelen); + gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO); } } if (GvIO(gv) && IoIFP(GvIOp(gv))) - fd = PerlIO_fileno(IoIFP(GvIOp(gv))); + fd = PerlIO_fileno(IoIFP(GvIOp(gv))); else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX) fd = (int)uv; else - fd = -1; + fd = -1; if (fd < 0) { SETERRNO(EBADF,RMS_IFI); - FT_RETURNUNDEF; + FT_RETURNUNDEF; } if (PerlLIO_isatty(fd)) - FT_RETURNYES; + FT_RETURNYES; FT_RETURNNO; } @@ -3420,70 +3420,70 @@ PP(pp_fttext) tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B'); if (PL_op->op_flags & OPf_REF) - gv = cGVOP_gv; + gv = cGVOP_gv; else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) - == OPpFT_STACKED) - gv = PL_defgv; + == OPpFT_STACKED) + gv = PL_defgv; else { - sv = *PL_stack_sp; - gv = MAYBE_DEREF_GV_nomg(sv); + sv = *PL_stack_sp; + gv = MAYBE_DEREF_GV_nomg(sv); } if (gv) { - if (gv == PL_defgv) { - if (PL_statgv) - io = SvTYPE(PL_statgv) == SVt_PVIO - ? (IO *)PL_statgv - : GvIO(PL_statgv); - else { - goto really_filename; - } - } - else { - PL_statgv = gv; + if (gv == PL_defgv) { + if (PL_statgv) + io = SvTYPE(PL_statgv) == SVt_PVIO + ? (IO *)PL_statgv + : GvIO(PL_statgv); + else { + goto really_filename; + } + } + else { + PL_statgv = gv; SvPVCLEAR(PL_statname); - io = GvIO(PL_statgv); - } - PL_laststatval = -1; - PL_laststype = OP_STAT; - if (io && IoIFP(io)) { - int fd; - if (! PerlIO_has_base(IoIFP(io))) - DIE(aTHX_ "-T and -B not implemented on filehandles"); - fd = PerlIO_fileno(IoIFP(io)); - if (fd < 0) { + io = GvIO(PL_statgv); + } + PL_laststatval = -1; + PL_laststype = OP_STAT; + if (io && IoIFP(io)) { + int fd; + if (! PerlIO_has_base(IoIFP(io))) + DIE(aTHX_ "-T and -B not implemented on filehandles"); + fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) { SETERRNO(EBADF,RMS_IFI); - FT_RETURNUNDEF; + FT_RETURNUNDEF; } - PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); - if (PL_laststatval < 0) - FT_RETURNUNDEF; - if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */ - if (PL_op->op_type == OP_FTTEXT) - FT_RETURNNO; - else - FT_RETURNYES; + PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); + if (PL_laststatval < 0) + FT_RETURNUNDEF; + if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */ + if (PL_op->op_type == OP_FTTEXT) + FT_RETURNNO; + else + FT_RETURNYES; } - if (PerlIO_get_cnt(IoIFP(io)) <= 0) { - i = PerlIO_getc(IoIFP(io)); - if (i != EOF) - (void)PerlIO_ungetc(IoIFP(io),i); + if (PerlIO_get_cnt(IoIFP(io)) <= 0) { + i = PerlIO_getc(IoIFP(io)); + if (i != EOF) + (void)PerlIO_ungetc(IoIFP(io),i); else /* null file is anything */ FT_RETURNYES; - } - len = PerlIO_get_bufsiz(IoIFP(io)); - s = (STDCHAR *) PerlIO_get_base(IoIFP(io)); - /* sfio can have large buffers - limit to 512 */ - if (len > 512) - len = 512; - } - else { - SETERRNO(EBADF,RMS_IFI); - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); - FT_RETURNUNDEF; - } + } + len = PerlIO_get_bufsiz(IoIFP(io)); + s = (STDCHAR *) PerlIO_get_base(IoIFP(io)); + /* sfio can have large buffers - limit to 512 */ + if (len > 512) + len = 512; + } + else { + SETERRNO(EBADF,RMS_IFI); + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + FT_RETURNUNDEF; + } } else { const char *file; @@ -3493,7 +3493,7 @@ PP(pp_fttext) assert(sv); temp = SvPV_nomg_const(sv, temp_len); - sv_setpv(PL_statname, temp); + sv_setpv(PL_statname, temp); if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) { PL_laststatval = -1; PL_laststype = OP_STAT; @@ -3501,43 +3501,43 @@ PP(pp_fttext) } really_filename: file = SvPVX_const(PL_statname); - PL_statgv = NULL; - if (!(fp = PerlIO_open(file, "r"))) { - if (!gv) { - PL_laststatval = -1; - PL_laststype = OP_STAT; - } - if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { + PL_statgv = NULL; + if (!(fp = PerlIO_open(file, "r"))) { + if (!gv) { + PL_laststatval = -1; + PL_laststype = OP_STAT; + } + if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { /* PL_warn_nl is constant */ GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); - Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); GCC_DIAG_RESTORE_STMT; } - FT_RETURNUNDEF; - } - PL_laststype = OP_STAT; + FT_RETURNUNDEF; + } + PL_laststype = OP_STAT; fd = PerlIO_fileno(fp); if (fd < 0) { - (void)PerlIO_close(fp); + (void)PerlIO_close(fp); SETERRNO(EBADF,RMS_IFI); - FT_RETURNUNDEF; + FT_RETURNUNDEF; } - PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); - if (PL_laststatval < 0) { + PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); + if (PL_laststatval < 0) { dSAVE_ERRNO; - (void)PerlIO_close(fp); + (void)PerlIO_close(fp); RESTORE_ERRNO; - FT_RETURNUNDEF; - } - PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL); - len = PerlIO_read(fp, tbuf, sizeof(tbuf)); - (void)PerlIO_close(fp); - if (len <= 0) { - if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT) - FT_RETURNNO; /* special case NFS directories */ - FT_RETURNYES; /* null file is anything */ - } - s = tbuf; + FT_RETURNUNDEF; + } + PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL); + len = PerlIO_read(fp, tbuf, sizeof(tbuf)); + (void)PerlIO_close(fp); + if (len <= 0) { + if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT) + FT_RETURNNO; /* special case NFS directories */ + FT_RETURNYES; /* null file is anything */ + } + s = tbuf; } /* now scan s to look for textiness */ @@ -3545,7 +3545,7 @@ PP(pp_fttext) #if defined(DOSISH) || defined(USEMYBINMODE) /* ignore trailing ^Z on short files */ if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26) - --len; + --len; #endif assert(len); @@ -3570,14 +3570,14 @@ PP(pp_fttext) * things that wouldn't be in ASCII text or rich ASCII text. Count these * in 'odd' */ for (i = 0; i < len; i++, s++) { - if (!*s) { /* null never allowed in text */ - odd += len; - break; - } + if (!*s) { /* null never allowed in text */ + odd += len; + break; + } #ifdef USE_LOCALE_CTYPE if (IN_LC_RUNTIME(LC_CTYPE)) { if ( isPRINT_LC(*s) || isSPACE_LC(*s)) { - continue; + continue; } } else @@ -3597,9 +3597,9 @@ PP(pp_fttext) } if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */ - FT_RETURNNO; + FT_RETURNNO; else - FT_RETURNYES; + FT_RETURNYES; } /* File calls. */ @@ -3611,9 +3611,9 @@ PP(pp_chdir) GV *gv = NULL; if( MAXARG == 1 ) { - SV * const sv = POPs; - if (PL_op->op_flags & OPf_SPECIAL) { - gv = gv_fetchsv(sv, 0, SVt_PVIO); + SV * const sv = POPs; + if (PL_op->op_flags & OPf_SPECIAL) { + gv = gv_fetchsv(sv, 0, SVt_PVIO); if (!gv) { if (ckWARN(WARN_UNOPENED)) { Perl_warner(aTHX_ packWARN(WARN_UNOPENED), @@ -3624,13 +3624,13 @@ PP(pp_chdir) TAINT_PROPER("chdir"); RETURN; } - } + } else if (!(gv = MAYBE_DEREF_GV(sv))) - tmps = SvPV_nomg_const_nolen(sv); + tmps = SvPV_nomg_const_nolen(sv); } else { - HV * const table = GvHVn(PL_envgv); - SV **svp; + HV * const table = GvHVn(PL_envgv); + SV **svp; EXTEND(SP, 1); if ( (svp = hv_fetchs(table, "HOME", FALSE)) @@ -3653,26 +3653,26 @@ PP(pp_chdir) TAINT_PROPER("chdir"); if (gv) { #ifdef HAS_FCHDIR - IO* const io = GvIO(gv); - if (io) { - if (IoDIRP(io)) { - PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0); - } else if (IoIFP(io)) { + IO* const io = GvIO(gv); + if (io) { + if (IoDIRP(io)) { + PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0); + } else if (IoIFP(io)) { int fd = PerlIO_fileno(IoIFP(io)); if (fd < 0) { goto nuts; } PUSHi(fchdir(fd) >= 0); - } - else { + } + else { goto nuts; - } + } } else { goto nuts; } #else - DIE(aTHX_ PL_no_func, "fchdir"); + DIE(aTHX_ PL_no_func, "fchdir"); #endif } else @@ -3733,14 +3733,14 @@ PP(pp_rename) anum = PerlLIO_rename(tmps, tmps2); #else if (!(anum = PerlLIO_stat(tmps, &statbuf))) { - if (same_dirent(tmps2, tmps)) /* can always rename to same name */ - anum = 1; - else { - if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) - (void)UNLINK(tmps2); - if (!(anum = link(tmps, tmps2))) - anum = UNLINK(tmps); - } + if (same_dirent(tmps2, tmps)) /* can always rename to same name */ + anum = 1; + else { + if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) + (void)UNLINK(tmps2); + if (!(anum = link(tmps, tmps2))) + anum = UNLINK(tmps); + } } #endif SETi( anum >= 0 ); @@ -3759,28 +3759,28 @@ PP(pp_link) # ifndef HAS_LINK if (op_type == OP_LINK) - DIE(aTHX_ PL_no_func, "link"); + DIE(aTHX_ PL_no_func, "link"); # endif # ifndef HAS_SYMLINK if (op_type == OP_SYMLINK) - DIE(aTHX_ PL_no_func, "symlink"); + DIE(aTHX_ PL_no_func, "symlink"); # endif { - const char * const tmps2 = POPpconstx; - const char * const tmps = SvPV_nolen_const(TOPs); - TAINT_PROPER(PL_op_desc[op_type]); - result = + const char * const tmps2 = POPpconstx; + const char * const tmps = SvPV_nolen_const(TOPs); + TAINT_PROPER(PL_op_desc[op_type]); + result = # if defined(HAS_LINK) && defined(HAS_SYMLINK) - /* Both present - need to choose which. */ - (op_type == OP_LINK) ? - PerlLIO_link(tmps, tmps2) : PerlLIO_symlink(tmps, tmps2); + /* Both present - need to choose which. */ + (op_type == OP_LINK) ? + PerlLIO_link(tmps, tmps2) : PerlLIO_symlink(tmps, tmps2); # elif defined(HAS_LINK) /* Only have link, so calls to pp_symlink will have DIE()d above. */ - PerlLIO_link(tmps, tmps2); + PerlLIO_link(tmps, tmps2); # elif defined(HAS_SYMLINK) /* Only have symlink, so calls to pp_link will have DIE()d above. */ - PerlLIO_symlink(tmps, tmps2); + PerlLIO_symlink(tmps, tmps2); # endif } @@ -3813,7 +3813,7 @@ PP(pp_readlink) * it is impossible to know whether the result was truncated. */ len = PerlLIO_readlink(tmps, buf, sizeof(buf) - 1); if (len < 0) - RETPUSHUNDEF; + RETPUSHUNDEF; buf[len] = '\0'; PUSHp(buf, len); RETURN; @@ -3840,72 +3840,72 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename) my_strlcpy(cmdline, cmd, size); my_strlcat(cmdline, " ", size); for (s = cmdline + strlen(cmdline); *filename; ) { - *s++ = '\\'; - *s++ = *filename++; + *s++ = '\\'; + *s++ = *filename++; } if (s - cmdline < size) - my_strlcpy(s, " 2>&1", size - (s - cmdline)); + my_strlcpy(s, " 2>&1", size - (s - cmdline)); myfp = PerlProc_popen(cmdline, "r"); Safefree(cmdline); if (myfp) { - SV * const tmpsv = sv_newmortal(); - /* Need to save/restore 'PL_rs' ?? */ - s = sv_gets(tmpsv, myfp, 0); - (void)PerlProc_pclose(myfp); - if (s != NULL) { - int e; - for (e = 1; + SV * const tmpsv = sv_newmortal(); + /* Need to save/restore 'PL_rs' ?? */ + s = sv_gets(tmpsv, myfp, 0); + (void)PerlProc_pclose(myfp); + if (s != NULL) { + int e; + for (e = 1; #ifdef HAS_SYS_ERRLIST - e <= sys_nerr -#endif - ; e++) - { - /* you don't see this */ - const char * const errmsg = Strerror(e) ; - if (!errmsg) - break; - if (instr(s, errmsg)) { - SETERRNO(e,0); - return 0; - } - } - SETERRNO(0,0); + e <= sys_nerr +#endif + ; e++) + { + /* you don't see this */ + const char * const errmsg = Strerror(e) ; + if (!errmsg) + break; + if (instr(s, errmsg)) { + SETERRNO(e,0); + return 0; + } + } + SETERRNO(0,0); #ifndef EACCES #define EACCES EPERM #endif - if (instr(s, "cannot make")) - SETERRNO(EEXIST,RMS_FEX); - else if (instr(s, "existing file")) - SETERRNO(EEXIST,RMS_FEX); - else if (instr(s, "ile exists")) - SETERRNO(EEXIST,RMS_FEX); - else if (instr(s, "non-exist")) - SETERRNO(ENOENT,RMS_FNF); - else if (instr(s, "does not exist")) - SETERRNO(ENOENT,RMS_FNF); - else if (instr(s, "not empty")) - SETERRNO(EBUSY,SS_DEVOFFLINE); - else if (instr(s, "cannot access")) - SETERRNO(EACCES,RMS_PRV); - else - SETERRNO(EPERM,RMS_PRV); - return 0; - } - else { /* some mkdirs return no failure indication */ - Stat_t statbuf; - anum = (PerlLIO_stat(save_filename, &statbuf) >= 0); - if (PL_op->op_type == OP_RMDIR) - anum = !anum; - if (anum) - SETERRNO(0,0); - else - SETERRNO(EACCES,RMS_PRV); /* a guess */ - } - return anum; + if (instr(s, "cannot make")) + SETERRNO(EEXIST,RMS_FEX); + else if (instr(s, "existing file")) + SETERRNO(EEXIST,RMS_FEX); + else if (instr(s, "ile exists")) + SETERRNO(EEXIST,RMS_FEX); + else if (instr(s, "non-exist")) + SETERRNO(ENOENT,RMS_FNF); + else if (instr(s, "does not exist")) + SETERRNO(ENOENT,RMS_FNF); + else if (instr(s, "not empty")) + SETERRNO(EBUSY,SS_DEVOFFLINE); + else if (instr(s, "cannot access")) + SETERRNO(EACCES,RMS_PRV); + else + SETERRNO(EPERM,RMS_PRV); + return 0; + } + else { /* some mkdirs return no failure indication */ + Stat_t statbuf; + anum = (PerlLIO_stat(save_filename, &statbuf) >= 0); + if (PL_op->op_type == OP_RMDIR) + anum = !anum; + if (anum) + SETERRNO(0,0); + else + SETERRNO(EACCES,RMS_PRV); /* a guess */ + } + return anum; } else - return 0; + return 0; } #endif @@ -3922,11 +3922,11 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename) #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \ if ((len) > 1 && (tmps)[(len)-1] == '/') { \ - do { \ - (len)--; \ - } while ((len) > 1 && (tmps)[(len)-1] == '/'); \ - (tmps) = savepvn((tmps), (len)); \ - (copy) = TRUE; \ + do { \ + (len)--; \ + } while ((len) > 1 && (tmps)[(len)-1] == '/'); \ + (tmps) = savepvn((tmps), (len)); \ + (copy) = TRUE; \ } PP(pp_mkdir) @@ -3952,7 +3952,7 @@ PP(pp_mkdir) } #endif if (copy) - Safefree(tmps); + Safefree(tmps); RETURN; } @@ -3971,7 +3971,7 @@ PP(pp_rmdir) SETi( dooneliner("rmdir", tmps) ); #endif if (copy) - Safefree(tmps); + Safefree(tmps); RETURN; } @@ -3986,17 +3986,17 @@ PP(pp_open_dir) IO * const io = GvIOn(gv); if ((IoIFP(io) || IoOFP(io))) - Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle", - HEKfARG(GvENAME_HEK(gv))); + Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle", + HEKfARG(GvENAME_HEK(gv))); if (IoDIRP(io)) - PerlDir_close(IoDIRP(io)); + PerlDir_close(IoDIRP(io)); if (!(IoDIRP(io) = PerlDir_open(dirname))) - goto nope; + goto nope; RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS_DIR); + SETERRNO(EBADF,RMS_DIR); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "opendir"); @@ -4020,8 +4020,8 @@ PP(pp_readdir) IO * const io = GvIOn(gv); if (!IoDIRP(io)) { - Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "readdir() attempted on invalid dirhandle %" HEKf, + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "readdir() attempted on invalid dirhandle %" HEKf, HEKfARG(GvENAME_HEK(gv))); goto nope; } @@ -4047,11 +4047,11 @@ PP(pp_readdir) nope: if (!errno) - SETERRNO(EBADF,RMS_ISI); + SETERRNO(EBADF,RMS_ISI); if (gimme == G_ARRAY) - RETURN; + RETURN; else - RETPUSHUNDEF; + RETPUSHUNDEF; #endif } @@ -4070,8 +4070,8 @@ PP(pp_telldir) IO * const io = GvIOn(gv); if (!IoDIRP(io)) { - Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "telldir() attempted on invalid dirhandle %" HEKf, + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "telldir() attempted on invalid dirhandle %" HEKf, HEKfARG(GvENAME_HEK(gv))); goto nope; } @@ -4080,7 +4080,7 @@ PP(pp_telldir) RETURN; nope: if (!errno) - SETERRNO(EBADF,RMS_ISI); + SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "telldir"); @@ -4096,8 +4096,8 @@ PP(pp_seekdir) IO * const io = GvIOn(gv); if (!IoDIRP(io)) { - Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "seekdir() attempted on invalid dirhandle %" HEKf, + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "seekdir() attempted on invalid dirhandle %" HEKf, HEKfARG(GvENAME_HEK(gv))); goto nope; } @@ -4106,7 +4106,7 @@ PP(pp_seekdir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS_ISI); + SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "seekdir"); @@ -4121,16 +4121,16 @@ PP(pp_rewinddir) IO * const io = GvIOn(gv); if (!IoDIRP(io)) { - Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "rewinddir() attempted on invalid dirhandle %" HEKf, + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "rewinddir() attempted on invalid dirhandle %" HEKf, HEKfARG(GvENAME_HEK(gv))); - goto nope; + goto nope; } (void)PerlDir_rewind(IoDIRP(io)); RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS_ISI); + SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "rewinddir"); @@ -4145,8 +4145,8 @@ PP(pp_closedir) IO * const io = GvIOn(gv); if (!IoDIRP(io)) { - Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "closedir() attempted on invalid dirhandle %" HEKf, + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "closedir() attempted on invalid dirhandle %" HEKf, HEKfARG(GvENAME_HEK(gv))); goto nope; } @@ -4154,8 +4154,8 @@ PP(pp_closedir) PerlDir_close(IoDIRP(io)); #else if (PerlDir_close(IoDIRP(io)) < 0) { - IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */ - goto nope; + IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */ + goto nope; } #endif IoDIRP(io) = 0; @@ -4163,7 +4163,7 @@ PP(pp_closedir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,RMS_IFI); + SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "closedir"); @@ -4189,24 +4189,24 @@ PP(pp_fork) #endif childpid = PerlProc_fork(); if (childpid == 0) { - int sig; - PL_sig_pending = 0; - if (PL_psig_pend) - for (sig = 1; sig < SIG_SIZE; sig++) - PL_psig_pend[sig] = 0; + int sig; + PL_sig_pending = 0; + if (PL_psig_pend) + for (sig = 1; sig < SIG_SIZE; sig++) + PL_psig_pend[sig] = 0; } #ifdef HAS_SIGPROCMASK { - dSAVE_ERRNO; - sigprocmask(SIG_SETMASK, &oldmask, NULL); - RESTORE_ERRNO; + dSAVE_ERRNO; + sigprocmask(SIG_SETMASK, &oldmask, NULL); + RESTORE_ERRNO; } #endif if (childpid < 0) - RETPUSHUNDEF; + RETPUSHUNDEF; if (!childpid) { #ifdef PERL_USES_PL_PIDSTATUS - hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ + hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ #endif } PUSHi(childpid); @@ -4219,7 +4219,7 @@ PP(pp_fork) PERL_FLUSHALL_FOR_CHILD; childpid = PerlProc_fork(); if (childpid == -1) - RETPUSHUNDEF; + RETPUSHUNDEF; PUSHi(childpid); RETURN; #else @@ -4238,9 +4238,9 @@ PP(pp_wait) childpid = wait4pid(-1, &argflags, 0); else { while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && - errno == EINTR) { - PERL_ASYNC_CHECK(); - } + errno == EINTR) { + PERL_ASYNC_CHECK(); + } } # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ @@ -4274,9 +4274,9 @@ PP(pp_waitpid) result = wait4pid(pid, &argflags, optype); else { while ((result = wait4pid(pid, &argflags, optype)) == -1 && - errno == EINTR) { - PERL_ASYNC_CHECK(); - } + errno == EINTR) { + PERL_ASYNC_CHECK(); + } } # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) /* 0 and -1 are both error returns (the former applies to WNOHANG case) */ @@ -4308,45 +4308,45 @@ PP(pp_system) # endif while (++MARK <= SP) { - SV *origsv = *MARK, *copysv; - STRLEN len; - char *pv; - SvGETMAGIC(origsv); + SV *origsv = *MARK, *copysv; + STRLEN len; + char *pv; + SvGETMAGIC(origsv); #if defined(WIN32) || defined(__VMS) - /* - * Because of a nasty platform-specific variation on the meaning - * of arguments to this op, we must preserve numeric arguments - * as numeric, not just retain the string value. - */ - if (SvNIOK(origsv) || SvNIOKp(origsv)) { - copysv = newSV_type(SVt_PVNV); - sv_2mortal(copysv); - if (SvPOK(origsv) || SvPOKp(origsv)) { - pv = SvPV_nomg(origsv, len); - sv_setpvn(copysv, pv, len); - SvPOK_off(copysv); - } - if (SvIOK(origsv) || SvIOKp(origsv)) - SvIV_set(copysv, SvIVX(origsv)); - if (SvNOK(origsv) || SvNOKp(origsv)) - SvNV_set(copysv, SvNVX(origsv)); - SvFLAGS(copysv) |= SvFLAGS(origsv) & - (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK| - SVf_UTF8|SVf_IVisUV); - } else -#endif - { - pv = SvPV_nomg(origsv, len); - copysv = newSVpvn_flags(pv, len, - (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP); - } - *MARK = copysv; + /* + * Because of a nasty platform-specific variation on the meaning + * of arguments to this op, we must preserve numeric arguments + * as numeric, not just retain the string value. + */ + if (SvNIOK(origsv) || SvNIOKp(origsv)) { + copysv = newSV_type(SVt_PVNV); + sv_2mortal(copysv); + if (SvPOK(origsv) || SvPOKp(origsv)) { + pv = SvPV_nomg(origsv, len); + sv_setpvn(copysv, pv, len); + SvPOK_off(copysv); + } + if (SvIOK(origsv) || SvIOKp(origsv)) + SvIV_set(copysv, SvIVX(origsv)); + if (SvNOK(origsv) || SvNOKp(origsv)) + SvNV_set(copysv, SvNVX(origsv)); + SvFLAGS(copysv) |= SvFLAGS(origsv) & + (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK| + SVf_UTF8|SVf_IVisUV); + } else +#endif + { + pv = SvPV_nomg(origsv, len); + copysv = newSVpvn_flags(pv, len, + (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP); + } + *MARK = copysv; } MARK = ORIGMARK; if (TAINTING_get) { - TAINT_ENV(); - TAINT_PROPER("system"); + TAINT_ENV(); + TAINT_PROPER("system"); } PERL_FLUSHALL_FOR_CHILD; #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO) @@ -4355,17 +4355,17 @@ PP(pp_system) struct UserData userdata; pthread_t proc; #else - Pid_t childpid; + Pid_t childpid; #endif - int pp[2]; - I32 did_pipes = 0; + int pp[2]; + I32 did_pipes = 0; bool child_success = FALSE; #ifdef HAS_SIGPROCMASK - sigset_t newset, oldset; + sigset_t newset, oldset; #endif - if (PerlProc_pipe_cloexec(pp) >= 0) - did_pipes = 1; + if (PerlProc_pipe_cloexec(pp) >= 0) + did_pipes = 1; #ifdef __amigaos4__ amigaos_fork_set_userdata(aTHX_ &userdata, @@ -4377,73 +4377,73 @@ PP(pp_system) child_success = proc > 0; #else #ifdef HAS_SIGPROCMASK - sigemptyset(&newset); - sigaddset(&newset, SIGCHLD); - sigprocmask(SIG_BLOCK, &newset, &oldset); -#endif - while ((childpid = PerlProc_fork()) == -1) { - if (errno != EAGAIN) { - value = -1; - SP = ORIGMARK; - XPUSHi(value); - if (did_pipes) { - PerlLIO_close(pp[0]); - PerlLIO_close(pp[1]); - } + sigemptyset(&newset); + sigaddset(&newset, SIGCHLD); + sigprocmask(SIG_BLOCK, &newset, &oldset); +#endif + while ((childpid = PerlProc_fork()) == -1) { + if (errno != EAGAIN) { + value = -1; + SP = ORIGMARK; + XPUSHi(value); + if (did_pipes) { + PerlLIO_close(pp[0]); + PerlLIO_close(pp[1]); + } #ifdef HAS_SIGPROCMASK - sigprocmask(SIG_SETMASK, &oldset, NULL); + sigprocmask(SIG_SETMASK, &oldset, NULL); #endif - RETURN; - } - sleep(5); - } + RETURN; + } + sleep(5); + } child_success = childpid > 0; #endif - if (child_success) { - Sigsave_t ihand,qhand; /* place to save signals during system() */ - int status; + if (child_success) { + Sigsave_t ihand,qhand; /* place to save signals during system() */ + int status; #ifndef __amigaos4__ - if (did_pipes) - PerlLIO_close(pp[1]); + if (did_pipes) + PerlLIO_close(pp[1]); #endif #ifndef PERL_MICRO - rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand); - rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand); + rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand); + rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand); #endif #ifdef __amigaos4__ result = pthread_join(proc, (void **)&status); #else - do { - result = wait4pid(childpid, &status, 0); - } while (result == -1 && errno == EINTR); + do { + result = wait4pid(childpid, &status, 0); + } while (result == -1 && errno == EINTR); #endif #ifndef PERL_MICRO #ifdef HAS_SIGPROCMASK - sigprocmask(SIG_SETMASK, &oldset, NULL); + sigprocmask(SIG_SETMASK, &oldset, NULL); #endif - (void)rsignal_restore(SIGINT, &ihand); - (void)rsignal_restore(SIGQUIT, &qhand); + (void)rsignal_restore(SIGINT, &ihand); + (void)rsignal_restore(SIGQUIT, &qhand); #endif - STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status); - SP = ORIGMARK; - if (did_pipes) { - int errkid; - unsigned n = 0; + STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status); + SP = ORIGMARK; + if (did_pipes) { + int errkid; + unsigned n = 0; - while (n < sizeof(int)) { + while (n < sizeof(int)) { const SSize_t n1 = PerlLIO_read(pp[0], - (void*)(((char*)&errkid)+n), - (sizeof(int)) - n); - if (n1 <= 0) - break; - n += n1; - } - PerlLIO_close(pp[0]); - if (n) { /* Error */ - if (n != sizeof(int)) - DIE(aTHX_ "panic: kid popen errno read, n=%u", n); - errno = errkid; /* Propagate errno from kid */ + (void*)(((char*)&errkid)+n), + (sizeof(int)) - n); + if (n1 <= 0) + break; + n += n1; + } + PerlLIO_close(pp[0]); + if (n) { /* Error */ + if (n != sizeof(int)) + DIE(aTHX_ "panic: kid popen errno read, n=%u", n); + errno = errkid; /* Propagate errno from kid */ #ifdef __amigaos4__ /* The pipe always has something in it * so n alone is not enough. */ @@ -4452,52 +4452,52 @@ PP(pp_system) { STATUS_NATIVE_CHILD_SET(-1); } - } - } - XPUSHi(STATUS_CURRENT); - RETURN; - } + } + } + XPUSHi(STATUS_CURRENT); + RETURN; + } #ifndef __amigaos4__ #ifdef HAS_SIGPROCMASK - sigprocmask(SIG_SETMASK, &oldset, NULL); -#endif - if (did_pipes) - PerlLIO_close(pp[0]); - if (PL_op->op_flags & OPf_STACKED) { - SV * const really = *++MARK; - value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes); - } - else if (SP - MARK != 1) - value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes); - else { - value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes); - } + sigprocmask(SIG_SETMASK, &oldset, NULL); +#endif + if (did_pipes) + PerlLIO_close(pp[0]); + if (PL_op->op_flags & OPf_STACKED) { + SV * const really = *++MARK; + value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes); + } + else if (SP - MARK != 1) + value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes); + else { + value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes); + } #endif /* __amigaos4__ */ - PerlProc__exit(-1); + PerlProc__exit(-1); } #else /* ! FORK or VMS or OS/2 */ PL_statusvalue = 0; result = 0; if (PL_op->op_flags & OPf_STACKED) { - SV * const really = *++MARK; + SV * const really = *++MARK; # if defined(WIN32) || defined(OS2) || defined(__VMS) - value = (I32)do_aspawn(really, MARK, SP); + value = (I32)do_aspawn(really, MARK, SP); # else - value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); + value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); # endif } else if (SP - MARK != 1) { # if defined(WIN32) || defined(OS2) || defined(__VMS) - value = (I32)do_aspawn(NULL, MARK, SP); + value = (I32)do_aspawn(NULL, MARK, SP); # else - value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP); + value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP); # endif } else { - value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); + value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP))); } if (PL_statusvalue == -1) /* hint that value must be returned as is */ - result = 1; + result = 1; STATUS_NATIVE_CHILD_SET(value); SP = ORIGMARK; XPUSHi(result ? value : STATUS_CURRENT); @@ -4512,32 +4512,32 @@ PP(pp_exec) I32 value; if (TAINTING_get) { - TAINT_ENV(); - while (++MARK <= SP) { - (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ - if (TAINT_get) - break; - } - MARK = ORIGMARK; - TAINT_PROPER("exec"); + TAINT_ENV(); + while (++MARK <= SP) { + (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ + if (TAINT_get) + break; + } + MARK = ORIGMARK; + TAINT_PROPER("exec"); } PERL_FLUSHALL_FOR_CHILD; if (PL_op->op_flags & OPf_STACKED) { - SV * const really = *++MARK; - value = (I32)do_aexec(really, MARK, SP); + SV * const really = *++MARK; + value = (I32)do_aexec(really, MARK, SP); } else if (SP - MARK != 1) #ifdef VMS - value = (I32)vms_do_aexec(NULL, MARK, SP); + value = (I32)vms_do_aexec(NULL, MARK, SP); #else - value = (I32)do_aexec(NULL, MARK, SP); + value = (I32)do_aexec(NULL, MARK, SP); #endif else { #ifdef VMS - value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); + value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); #else - value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); + value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); #endif } SP = ORIGMARK; @@ -4562,13 +4562,13 @@ PP(pp_getpgrp) dSP; dTARGET; Pid_t pgrp; const Pid_t pid = - (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0); + (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0); #ifdef BSD_GETPGRP pgrp = (I32)BSD_GETPGRP(pid); #else if (pid != 0 && pid != PerlProc_getpid()) - DIE(aTHX_ "POSIX getpgrp can't take an argument"); + DIE(aTHX_ "POSIX getpgrp can't take an argument"); pgrp = getpgrp(); #endif XPUSHi(pgrp); @@ -4587,9 +4587,9 @@ PP(pp_setpgrp) pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0; if (MAXARG > 0) pid = TOPs ? TOPi : 0; else { - pid = 0; - EXTEND(SP,1); - SP++; + pid = 0; + EXTEND(SP,1); + SP++; } TAINT_PROPER("setpgrp"); @@ -4597,9 +4597,9 @@ PP(pp_setpgrp) SETi( BSD_SETPGRP(pid, pgrp) >= 0 ); #else if ((pgrp != 0 && pgrp != PerlProc_getpid()) - || (pid != 0 && pid != PerlProc_getpid())) + || (pid != 0 && pid != PerlProc_getpid())) { - DIE(aTHX_ "setpgrp can't take arguments"); + DIE(aTHX_ "setpgrp can't take arguments"); } SETi( setpgrp() >= 0 ); #endif /* USE_BSDPGRP */ @@ -4674,9 +4674,9 @@ PP(pp_tms) mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick); if (GIMME_V == G_ARRAY) { - mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick); - mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick); - mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick); + mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick); + mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick); + mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick); } RETURN; #elif defined(PERL_MICRO) @@ -4684,9 +4684,9 @@ PP(pp_tms) mPUSHn(0.0); EXTEND(SP, 4); if (GIMME_V == G_ARRAY) { - mPUSHn(0.0); - mPUSHn(0.0); - mPUSHn(0.0); + mPUSHn(0.0); + mPUSHn(0.0); + mPUSHn(0.0); } RETURN; #else @@ -4714,62 +4714,62 @@ PP(pp_gmtime) struct TM *err; const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime"; static const char * const dayname[] = - {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; + {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"}; static const char * const monname[] = - {"Jan", "Feb", "Mar", "Apr", "May", "Jun", - "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; + {"Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"}; if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) { - time_t now; - (void)time(&now); - when = (Time64_T)now; + time_t now; + (void)time(&now); + when = (Time64_T)now; } else { - NV input = Perl_floor(POPn); - const bool pl_isnan = Perl_isnan(input); - when = (Time64_T)input; - if (UNLIKELY(pl_isnan || when != input)) { - /* diag_listed_as: gmtime(%f) too large */ - Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "%s(%.0" NVff ") too large", opname, input); - if (pl_isnan) { - err = NULL; - goto failed; - } - } + NV input = Perl_floor(POPn); + const bool pl_isnan = Perl_isnan(input); + when = (Time64_T)input; + if (UNLIKELY(pl_isnan || when != input)) { + /* diag_listed_as: gmtime(%f) too large */ + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0" NVff ") too large", opname, input); + if (pl_isnan) { + err = NULL; + goto failed; + } + } } if ( TIME_LOWER_BOUND > when ) { - /* diag_listed_as: gmtime(%f) too small */ - Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "%s(%.0" NVff ") too small", opname, when); - err = NULL; + /* diag_listed_as: gmtime(%f) too small */ + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0" NVff ") too small", opname, when); + err = NULL; } else if( when > TIME_UPPER_BOUND ) { - /* diag_listed_as: gmtime(%f) too small */ - Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "%s(%.0" NVff ") too large", opname, when); - err = NULL; + /* diag_listed_as: gmtime(%f) too small */ + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0" NVff ") too large", opname, when); + err = NULL; } else { - if (PL_op->op_type == OP_LOCALTIME) - err = Perl_localtime64_r(&when, &tmbuf); - else - err = Perl_gmtime64_r(&when, &tmbuf); + if (PL_op->op_type == OP_LOCALTIME) + err = Perl_localtime64_r(&when, &tmbuf); + else + err = Perl_gmtime64_r(&when, &tmbuf); } if (err == NULL) { - /* diag_listed_as: gmtime(%f) failed */ - /* XXX %lld broken for quads */ + /* diag_listed_as: gmtime(%f) failed */ + /* XXX %lld broken for quads */ failed: - Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "%s(%.0" NVff ") failed", opname, when); + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0" NVff ") failed", opname, when); } if (GIMME_V != G_ARRAY) { /* scalar context */ EXTEND(SP, 1); - if (err == NULL) - RETPUSHUNDEF; + if (err == NULL) + RETPUSHUNDEF; else { dTARGET; PUSHs(TARG); @@ -4784,20 +4784,20 @@ PP(pp_gmtime) } } else { /* list context */ - if ( err == NULL ) - RETURN; + if ( err == NULL ) + RETURN; EXTEND(SP, 9); EXTEND_MORTAL(9); mPUSHi(tmbuf.tm_sec); - mPUSHi(tmbuf.tm_min); - mPUSHi(tmbuf.tm_hour); - mPUSHi(tmbuf.tm_mday); - mPUSHi(tmbuf.tm_mon); - mPUSHn(tmbuf.tm_year); - mPUSHi(tmbuf.tm_wday); - mPUSHi(tmbuf.tm_yday); - mPUSHi(tmbuf.tm_isdst); + mPUSHi(tmbuf.tm_min); + mPUSHi(tmbuf.tm_hour); + mPUSHi(tmbuf.tm_mday); + mPUSHi(tmbuf.tm_mon); + mPUSHn(tmbuf.tm_year); + mPUSHi(tmbuf.tm_wday); + mPUSHi(tmbuf.tm_yday); + mPUSHi(tmbuf.tm_isdst); } RETURN; } @@ -4843,7 +4843,7 @@ PP(pp_sleep) (void)time(&lasttime); if (MAXARG < 1 || (!TOPs && !POPs)) - PerlProc_pause(); + PerlProc_pause(); else { const I32 duration = POPi; if (duration < 0) { @@ -4876,17 +4876,17 @@ PP(pp_shmwrite) switch (op_type) { case OP_MSGSND: - value = (I32)(do_msgsnd(MARK, SP) >= 0); - break; + value = (I32)(do_msgsnd(MARK, SP) >= 0); + break; case OP_MSGRCV: - value = (I32)(do_msgrcv(MARK, SP) >= 0); - break; + value = (I32)(do_msgrcv(MARK, SP) >= 0); + break; case OP_SEMOP: - value = (I32)(do_semop(MARK, SP) >= 0); - break; + value = (I32)(do_semop(MARK, SP) >= 0); + break; default: - value = (I32)(do_shmio(op_type, MARK, SP) >= 0); - break; + value = (I32)(do_shmio(op_type, MARK, SP) >= 0); + break; } SP = MARK; @@ -4908,7 +4908,7 @@ PP(pp_semget) const int anum = do_ipcget(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) - RETPUSHUNDEF; + RETPUSHUNDEF; PUSHi(anum); RETURN; #else @@ -4925,12 +4925,12 @@ PP(pp_semctl) const int anum = do_ipcctl(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) - RETPUSHUNDEF; + RETPUSHUNDEF; if (anum != 0) { - PUSHi(anum); + PUSHi(anum); } else { - PUSHp(zero_but_true, ZBTLEN); + PUSHp(zero_but_true, ZBTLEN); } RETURN; #else @@ -4946,15 +4946,15 @@ S_space_join_names_mortal(pTHX_ char *const *array) SV *target; if (array && *array) { - target = newSVpvs_flags("", SVs_TEMP); - while (1) { - sv_catpv(target, *array); - if (!*++array) - break; - sv_catpvs(target, " "); - } + target = newSVpvs_flags("", SVs_TEMP); + while (1) { + sv_catpv(target, *array); + if (!*++array) + break; + sv_catpvs(target, " "); + } } else { - target = sv_mortalcopy(&PL_sv_no); + target = sv_mortalcopy(&PL_sv_no); } return target; } @@ -4981,70 +4981,70 @@ PP(pp_ghostent) EXTEND(SP, 10); if (which == OP_GHBYNAME) { #ifdef HAS_GETHOSTBYNAME - const char* const name = POPpbytex; - hent = PerlSock_gethostbyname(name); + const char* const name = POPpbytex; + hent = PerlSock_gethostbyname(name); #else - DIE(aTHX_ PL_no_sock_func, "gethostbyname"); + DIE(aTHX_ PL_no_sock_func, "gethostbyname"); #endif } else if (which == OP_GHBYADDR) { #ifdef HAS_GETHOSTBYADDR - const int addrtype = POPi; - SV * const addrsv = POPs; - STRLEN addrlen; - const char *addr = (char *)SvPVbyte(addrsv, addrlen); + const int addrtype = POPi; + SV * const addrsv = POPs; + STRLEN addrlen; + const char *addr = (char *)SvPVbyte(addrsv, addrlen); - hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype); + hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype); #else - DIE(aTHX_ PL_no_sock_func, "gethostbyaddr"); + DIE(aTHX_ PL_no_sock_func, "gethostbyaddr"); #endif } else #ifdef HAS_GETHOSTENT - hent = PerlSock_gethostent(); + hent = PerlSock_gethostent(); #else - DIE(aTHX_ PL_no_sock_func, "gethostent"); + DIE(aTHX_ PL_no_sock_func, "gethostent"); #endif #ifdef HOST_NOT_FOUND - if (!hent) { + if (!hent) { #ifdef USE_REENTRANT_API # ifdef USE_GETHOSTENT_ERRNO - h_errno = PL_reentrant_buffer->_gethostent_errno; + h_errno = PL_reentrant_buffer->_gethostent_errno; # endif #endif - STATUS_UNIX_SET(h_errno); - } + STATUS_UNIX_SET(h_errno); + } #endif if (GIMME_V != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (hent) { - if (which == OP_GHBYNAME) { - if (hent->h_addr) - sv_setpvn(sv, hent->h_addr, hent->h_length); - } - else - sv_setpv(sv, (char*)hent->h_name); - } - RETURN; + PUSHs(sv = sv_newmortal()); + if (hent) { + if (which == OP_GHBYNAME) { + if (hent->h_addr) + sv_setpvn(sv, hent->h_addr, hent->h_length); + } + else + sv_setpv(sv, (char*)hent->h_name); + } + RETURN; } if (hent) { - mPUSHs(newSVpv((char*)hent->h_name, 0)); - PUSHs(space_join_names_mortal(hent->h_aliases)); - mPUSHi(hent->h_addrtype); - len = hent->h_length; - mPUSHi(len); + mPUSHs(newSVpv((char*)hent->h_name, 0)); + PUSHs(space_join_names_mortal(hent->h_aliases)); + mPUSHi(hent->h_addrtype); + len = hent->h_length; + mPUSHi(len); #ifdef h_addr - for (elem = hent->h_addr_list; elem && *elem; elem++) { - mXPUSHp(*elem, len); - } + for (elem = hent->h_addr_list; elem && *elem; elem++) { + mXPUSHp(*elem, len); + } #else - if (hent->h_addr) - mPUSHp(hent->h_addr, len); - else - PUSHs(sv_mortalcopy(&PL_sv_no)); + if (hent->h_addr) + mPUSHp(hent->h_addr, len); + else + PUSHs(sv_mortalcopy(&PL_sv_no)); #endif /* h_addr */ } RETURN; @@ -5070,56 +5070,56 @@ PP(pp_gnetent) if (which == OP_GNBYNAME){ #ifdef HAS_GETNETBYNAME - const char * const name = POPpbytex; - nent = PerlSock_getnetbyname(name); + const char * const name = POPpbytex; + nent = PerlSock_getnetbyname(name); #else DIE(aTHX_ PL_no_sock_func, "getnetbyname"); #endif } else if (which == OP_GNBYADDR) { #ifdef HAS_GETNETBYADDR - const int addrtype = POPi; - const Netdb_net_t addr = (Netdb_net_t) (U32)POPu; - nent = PerlSock_getnetbyaddr(addr, addrtype); + const int addrtype = POPi; + const Netdb_net_t addr = (Netdb_net_t) (U32)POPu; + nent = PerlSock_getnetbyaddr(addr, addrtype); #else - DIE(aTHX_ PL_no_sock_func, "getnetbyaddr"); + DIE(aTHX_ PL_no_sock_func, "getnetbyaddr"); #endif } else #ifdef HAS_GETNETENT - nent = PerlSock_getnetent(); + nent = PerlSock_getnetent(); #else DIE(aTHX_ PL_no_sock_func, "getnetent"); #endif #ifdef HOST_NOT_FOUND - if (!nent) { + if (!nent) { #ifdef USE_REENTRANT_API # ifdef USE_GETNETENT_ERRNO - h_errno = PL_reentrant_buffer->_getnetent_errno; + h_errno = PL_reentrant_buffer->_getnetent_errno; # endif #endif - STATUS_UNIX_SET(h_errno); - } + STATUS_UNIX_SET(h_errno); + } #endif EXTEND(SP, 4); if (GIMME_V != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (nent) { - if (which == OP_GNBYNAME) - sv_setiv(sv, (IV)nent->n_net); - else - sv_setpv(sv, nent->n_name); - } - RETURN; + PUSHs(sv = sv_newmortal()); + if (nent) { + if (which == OP_GNBYNAME) + sv_setiv(sv, (IV)nent->n_net); + else + sv_setpv(sv, nent->n_name); + } + RETURN; } if (nent) { - mPUSHs(newSVpv(nent->n_name, 0)); - PUSHs(space_join_names_mortal(nent->n_aliases)); - mPUSHi(nent->n_addrtype); - mPUSHi(nent->n_net); + mPUSHs(newSVpv(nent->n_name, 0)); + PUSHs(space_join_names_mortal(nent->n_aliases)); + mPUSHi(nent->n_addrtype); + mPUSHi(nent->n_net); } RETURN; @@ -5146,43 +5146,43 @@ PP(pp_gprotoent) if (which == OP_GPBYNAME) { #ifdef HAS_GETPROTOBYNAME - const char* const name = POPpbytex; - pent = PerlSock_getprotobyname(name); + const char* const name = POPpbytex; + pent = PerlSock_getprotobyname(name); #else - DIE(aTHX_ PL_no_sock_func, "getprotobyname"); + DIE(aTHX_ PL_no_sock_func, "getprotobyname"); #endif } else if (which == OP_GPBYNUMBER) { #ifdef HAS_GETPROTOBYNUMBER - const int number = POPi; - pent = PerlSock_getprotobynumber(number); + const int number = POPi; + pent = PerlSock_getprotobynumber(number); #else - DIE(aTHX_ PL_no_sock_func, "getprotobynumber"); + DIE(aTHX_ PL_no_sock_func, "getprotobynumber"); #endif } else #ifdef HAS_GETPROTOENT - pent = PerlSock_getprotoent(); + pent = PerlSock_getprotoent(); #else - DIE(aTHX_ PL_no_sock_func, "getprotoent"); + DIE(aTHX_ PL_no_sock_func, "getprotoent"); #endif EXTEND(SP, 3); if (GIMME_V != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (pent) { - if (which == OP_GPBYNAME) - sv_setiv(sv, (IV)pent->p_proto); - else - sv_setpv(sv, pent->p_name); - } - RETURN; + PUSHs(sv = sv_newmortal()); + if (pent) { + if (which == OP_GPBYNAME) + sv_setiv(sv, (IV)pent->p_proto); + else + sv_setpv(sv, pent->p_name); + } + RETURN; } if (pent) { - mPUSHs(newSVpv(pent->p_name, 0)); - PUSHs(space_join_names_mortal(pent->p_aliases)); - mPUSHi(pent->p_proto); + mPUSHs(newSVpv(pent->p_name, 0)); + PUSHs(space_join_names_mortal(pent->p_aliases)); + mPUSHi(pent->p_proto); } RETURN; @@ -5209,48 +5209,48 @@ PP(pp_gservent) if (which == OP_GSBYNAME) { #ifdef HAS_GETSERVBYNAME - const char * const proto = POPpbytex; - const char * const name = POPpbytex; - sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto); + const char * const proto = POPpbytex; + const char * const name = POPpbytex; + sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto); #else - DIE(aTHX_ PL_no_sock_func, "getservbyname"); + DIE(aTHX_ PL_no_sock_func, "getservbyname"); #endif } else if (which == OP_GSBYPORT) { #ifdef HAS_GETSERVBYPORT - const char * const proto = POPpbytex; - unsigned short port = (unsigned short)POPu; - port = PerlSock_htons(port); - sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto); + const char * const proto = POPpbytex; + unsigned short port = (unsigned short)POPu; + port = PerlSock_htons(port); + sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto); #else - DIE(aTHX_ PL_no_sock_func, "getservbyport"); + DIE(aTHX_ PL_no_sock_func, "getservbyport"); #endif } else #ifdef HAS_GETSERVENT - sent = PerlSock_getservent(); + sent = PerlSock_getservent(); #else - DIE(aTHX_ PL_no_sock_func, "getservent"); + DIE(aTHX_ PL_no_sock_func, "getservent"); #endif EXTEND(SP, 4); if (GIMME_V != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (sent) { - if (which == OP_GSBYNAME) { - sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port)); - } - else - sv_setpv(sv, sent->s_name); - } - RETURN; + PUSHs(sv = sv_newmortal()); + if (sent) { + if (which == OP_GSBYNAME) { + sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port)); + } + else + sv_setpv(sv, sent->s_name); + } + RETURN; } if (sent) { - mPUSHs(newSVpv(sent->s_name, 0)); - PUSHs(space_join_names_mortal(sent->s_aliases)); - mPUSHi(PerlSock_ntohs(sent->s_port)); - mPUSHs(newSVpv(sent->s_proto, 0)); + mPUSHs(newSVpv(sent->s_name, 0)); + PUSHs(space_join_names_mortal(sent->s_aliases)); + mPUSHi(PerlSock_ntohs(sent->s_port)); + mPUSHs(newSVpv(sent->s_proto, 0)); } RETURN; @@ -5269,32 +5269,32 @@ PP(pp_shostent) switch(PL_op->op_type) { case OP_SHOSTENT: #ifdef HAS_SETHOSTENT - PerlSock_sethostent(stayopen); + PerlSock_sethostent(stayopen); #else - DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; case OP_SNETENT: #ifdef HAS_SETNETENT - PerlSock_setnetent(stayopen); + PerlSock_setnetent(stayopen); #else - DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; case OP_SPROTOENT: #ifdef HAS_SETPROTOENT - PerlSock_setprotoent(stayopen); + PerlSock_setprotoent(stayopen); #else - DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; case OP_SSERVENT: #ifdef HAS_SETSERVENT - PerlSock_setservent(stayopen); + PerlSock_setservent(stayopen); #else - DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; } RETSETYES; } @@ -5309,60 +5309,60 @@ PP(pp_ehostent) switch(PL_op->op_type) { case OP_EHOSTENT: #ifdef HAS_ENDHOSTENT - PerlSock_endhostent(); + PerlSock_endhostent(); #else - DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; case OP_ENETENT: #ifdef HAS_ENDNETENT - PerlSock_endnetent(); + PerlSock_endnetent(); #else - DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; case OP_EPROTOENT: #ifdef HAS_ENDPROTOENT - PerlSock_endprotoent(); + PerlSock_endprotoent(); #else - DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; case OP_ESERVENT: #ifdef HAS_ENDSERVENT - PerlSock_endservent(); + PerlSock_endservent(); #else - DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; case OP_SGRENT: #if defined(HAS_GROUP) && defined(HAS_SETGRENT) - setgrent(); + setgrent(); #else - DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; case OP_EGRENT: #if defined(HAS_GROUP) && defined(HAS_ENDGRENT) - endgrent(); + endgrent(); #else - DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; case OP_SPWENT: #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) - setpwent(); + setpwent(); #else - DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; case OP_EPWENT: #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT) - endpwent(); + endpwent(); #else - DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); + DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]); #endif - break; + break; } EXTEND(SP,1); RETPUSHYES; @@ -5447,131 +5447,131 @@ PP(pp_gpwent) switch (which) { case OP_GPWNAM: { - const char* const name = POPpbytex; - pwent = getpwnam(name); + const char* const name = POPpbytex; + pwent = getpwnam(name); } break; case OP_GPWUID: { - Uid_t uid = POPi; - pwent = getpwuid(uid); + Uid_t uid = POPi; + pwent = getpwuid(uid); } - break; + break; case OP_GPWENT: # ifdef HAS_GETPWENT - pwent = getpwent(); + pwent = getpwent(); #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */ - if (pwent) pwent = getpwnam(pwent->pw_name); + if (pwent) pwent = getpwnam(pwent->pw_name); #endif # else - DIE(aTHX_ PL_no_func, "getpwent"); + DIE(aTHX_ PL_no_func, "getpwent"); # endif - break; + break; } EXTEND(SP, 10); if (GIMME_V != G_ARRAY) { - PUSHs(sv = sv_newmortal()); - if (pwent) { - if (which == OP_GPWNAM) - sv_setuid(sv, pwent->pw_uid); - else - sv_setpv(sv, pwent->pw_name); - } - RETURN; + PUSHs(sv = sv_newmortal()); + if (pwent) { + if (which == OP_GPWNAM) + sv_setuid(sv, pwent->pw_uid); + else + sv_setpv(sv, pwent->pw_name); + } + RETURN; } if (pwent) { - mPUSHs(newSVpv(pwent->pw_name, 0)); - - sv = newSViv(0); - mPUSHs(sv); - /* If we have getspnam(), we try to dig up the shadow - * password. If we are underprivileged, the shadow - * interface will set the errno to EACCES or similar, - * and return a null pointer. If this happens, we will - * use the dummy password (usually "*" or "x") from the - * standard password database. - * - * In theory we could skip the shadow call completely - * if euid != 0 but in practice we cannot know which - * security measures are guarding the shadow databases - * on a random platform. - * - * Resist the urge to use additional shadow interfaces. - * Divert the urge to writing an extension instead. - * - * --jhi */ - /* Some AIX setups falsely(?) detect some getspnam(), which - * has a different API than the Solaris/IRIX one. */ + mPUSHs(newSVpv(pwent->pw_name, 0)); + + sv = newSViv(0); + mPUSHs(sv); + /* If we have getspnam(), we try to dig up the shadow + * password. If we are underprivileged, the shadow + * interface will set the errno to EACCES or similar, + * and return a null pointer. If this happens, we will + * use the dummy password (usually "*" or "x") from the + * standard password database. + * + * In theory we could skip the shadow call completely + * if euid != 0 but in practice we cannot know which + * security measures are guarding the shadow databases + * on a random platform. + * + * Resist the urge to use additional shadow interfaces. + * Divert the urge to writing an extension instead. + * + * --jhi */ + /* Some AIX setups falsely(?) detect some getspnam(), which + * has a different API than the Solaris/IRIX one. */ # if defined(HAS_GETSPNAM) && !defined(_AIX) - { - dSAVE_ERRNO; - const struct spwd * const spwent = getspnam(pwent->pw_name); - /* Save and restore errno so that - * underprivileged attempts seem - * to have never made the unsuccessful - * attempt to retrieve the shadow password. */ - RESTORE_ERRNO; - if (spwent && spwent->sp_pwdp) - sv_setpv(sv, spwent->sp_pwdp); - } + { + dSAVE_ERRNO; + const struct spwd * const spwent = getspnam(pwent->pw_name); + /* Save and restore errno so that + * underprivileged attempts seem + * to have never made the unsuccessful + * attempt to retrieve the shadow password. */ + RESTORE_ERRNO; + if (spwent && spwent->sp_pwdp) + sv_setpv(sv, spwent->sp_pwdp); + } # endif # ifdef PWPASSWD - if (!SvPOK(sv)) /* Use the standard password, then. */ - sv_setpv(sv, pwent->pw_passwd); + if (!SvPOK(sv)) /* Use the standard password, then. */ + sv_setpv(sv, pwent->pw_passwd); # endif - /* passwd is tainted because user himself can diddle with it. - * admittedly not much and in a very limited way, but nevertheless. */ - SvTAINTED_on(sv); + /* passwd is tainted because user himself can diddle with it. + * admittedly not much and in a very limited way, but nevertheless. */ + SvTAINTED_on(sv); sv_setuid(PUSHmortal, pwent->pw_uid); sv_setgid(PUSHmortal, pwent->pw_gid); - /* pw_change, pw_quota, and pw_age are mutually exclusive-- - * because of the poor interface of the Perl getpw*(), - * not because there's some standard/convention saying so. - * A better interface would have been to return a hash, - * but we are accursed by our history, alas. --jhi. */ + /* pw_change, pw_quota, and pw_age are mutually exclusive-- + * because of the poor interface of the Perl getpw*(), + * not because there's some standard/convention saying so. + * A better interface would have been to return a hash, + * but we are accursed by our history, alas. --jhi. */ # ifdef PWCHANGE - mPUSHi(pwent->pw_change); + mPUSHi(pwent->pw_change); # elif defined(PWQUOTA) - mPUSHi(pwent->pw_quota); + mPUSHi(pwent->pw_quota); # elif defined(PWAGE) - mPUSHs(newSVpv(pwent->pw_age, 0)); + mPUSHs(newSVpv(pwent->pw_age, 0)); # else - /* I think that you can never get this compiled, but just in case. */ - PUSHs(sv_mortalcopy(&PL_sv_no)); + /* I think that you can never get this compiled, but just in case. */ + PUSHs(sv_mortalcopy(&PL_sv_no)); # endif - /* pw_class and pw_comment are mutually exclusive--. - * see the above note for pw_change, pw_quota, and pw_age. */ + /* pw_class and pw_comment are mutually exclusive--. + * see the above note for pw_change, pw_quota, and pw_age. */ # ifdef PWCLASS - mPUSHs(newSVpv(pwent->pw_class, 0)); + mPUSHs(newSVpv(pwent->pw_class, 0)); # elif defined(PWCOMMENT) - mPUSHs(newSVpv(pwent->pw_comment, 0)); + mPUSHs(newSVpv(pwent->pw_comment, 0)); # else - /* I think that you can never get this compiled, but just in case. */ - PUSHs(sv_mortalcopy(&PL_sv_no)); + /* I think that you can never get this compiled, but just in case. */ + PUSHs(sv_mortalcopy(&PL_sv_no)); # endif # ifdef PWGECOS - PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0))); + PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0))); # else - PUSHs(sv = sv_mortalcopy(&PL_sv_no)); + PUSHs(sv = sv_mortalcopy(&PL_sv_no)); # endif - /* pw_gecos is tainted because user himself can diddle with it. */ - SvTAINTED_on(sv); + /* pw_gecos is tainted because user himself can diddle with it. */ + SvTAINTED_on(sv); - mPUSHs(newSVpv(pwent->pw_dir, 0)); + mPUSHs(newSVpv(pwent->pw_dir, 0)); - PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0))); - /* pw_shell is tainted because user himself can diddle with it. */ - SvTAINTED_on(sv); + PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0))); + /* pw_shell is tainted because user himself can diddle with it. */ + SvTAINTED_on(sv); # ifdef PWEXPIRE - mPUSHi(pwent->pw_expire); + mPUSHi(pwent->pw_expire); # endif } RETURN; @@ -5591,61 +5591,61 @@ PP(pp_ggrent) const struct group *grent; if (which == OP_GGRNAM) { - const char* const name = POPpbytex; - grent = (const struct group *)getgrnam(name); + const char* const name = POPpbytex; + grent = (const struct group *)getgrnam(name); } else if (which == OP_GGRGID) { #if Gid_t_sign == 1 - const Gid_t gid = POPu; + const Gid_t gid = POPu; #elif Gid_t_sign == -1 - const Gid_t gid = POPi; + const Gid_t gid = POPi; #else # error "Unexpected Gid_t_sign" #endif - grent = (const struct group *)getgrgid(gid); + grent = (const struct group *)getgrgid(gid); } else #ifdef HAS_GETGRENT - grent = (struct group *)getgrent(); + grent = (struct group *)getgrent(); #else DIE(aTHX_ PL_no_func, "getgrent"); #endif EXTEND(SP, 4); if (GIMME_V != G_ARRAY) { - SV * const sv = sv_newmortal(); + SV * const sv = sv_newmortal(); - PUSHs(sv); - if (grent) { - if (which == OP_GGRNAM) - sv_setgid(sv, grent->gr_gid); - else - sv_setpv(sv, grent->gr_name); - } - RETURN; + PUSHs(sv); + if (grent) { + if (which == OP_GGRNAM) + sv_setgid(sv, grent->gr_gid); + else + sv_setpv(sv, grent->gr_name); + } + RETURN; } if (grent) { - mPUSHs(newSVpv(grent->gr_name, 0)); + mPUSHs(newSVpv(grent->gr_name, 0)); #ifdef GRPASSWD - mPUSHs(newSVpv(grent->gr_passwd, 0)); + mPUSHs(newSVpv(grent->gr_passwd, 0)); #else - PUSHs(sv_mortalcopy(&PL_sv_no)); + PUSHs(sv_mortalcopy(&PL_sv_no)); #endif sv_setgid(PUSHmortal, grent->gr_gid); #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API)) - /* In UNICOS/mk (_CRAYMPP) the multithreading - * versions (getgrnam_r, getgrgid_r) - * seem to return an illegal pointer - * as the group members list, gr_mem. - * getgrent() doesn't even have a _r version - * but the gr_mem is poisonous anyway. - * So yes, you cannot get the list of group - * members if building multithreaded in UNICOS/mk. */ - PUSHs(space_join_names_mortal(grent->gr_mem)); + /* In UNICOS/mk (_CRAYMPP) the multithreading + * versions (getgrnam_r, getgrgid_r) + * seem to return an illegal pointer + * as the group members list, gr_mem. + * getgrent() doesn't even have a _r version + * but the gr_mem is poisonous anyway. + * So yes, you cannot get the list of group + * members if building multithreaded in UNICOS/mk. */ + PUSHs(space_join_names_mortal(grent->gr_mem)); #endif } @@ -5662,7 +5662,7 @@ PP(pp_getlogin) char *tmps; EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin())) - RETPUSHUNDEF; + RETPUSHUNDEF; sv_setpv_mg(TARG, tmps); PUSHs(TARG); RETURN; @@ -5683,14 +5683,14 @@ PP(pp_syscall) IV retval = -1; if (TAINTING_get) { - while (++MARK <= SP) { - if (SvTAINTED(*MARK)) { - TAINT; - break; - } - } - MARK = ORIGMARK; - TAINT_PROPER("syscall"); + while (++MARK <= SP) { + if (SvTAINTED(*MARK)) { + TAINT; + break; + } + } + MARK = ORIGMARK; + TAINT_PROPER("syscall"); } /* This probably won't work on machines where sizeof(long) != sizeof(int) @@ -5698,44 +5698,44 @@ PP(pp_syscall) * not likely have syscall implemented either, so who cares? */ while (++MARK <= SP) { - if (SvNIOK(*MARK) || !i) - a[i++] = SvIV(*MARK); - else if (*MARK == &PL_sv_undef) - a[i++] = 0; - else - a[i++] = (unsigned long)SvPV_force_nolen(*MARK); - if (i > 15) - break; + if (SvNIOK(*MARK) || !i) + a[i++] = SvIV(*MARK); + else if (*MARK == &PL_sv_undef) + a[i++] = 0; + else + a[i++] = (unsigned long)SvPV_force_nolen(*MARK); + if (i > 15) + break; } switch (items) { default: - DIE(aTHX_ "Too many args to syscall"); + DIE(aTHX_ "Too many args to syscall"); case 0: - DIE(aTHX_ "Too few args to syscall"); + DIE(aTHX_ "Too few args to syscall"); case 1: - retval = syscall(a[0]); - break; + retval = syscall(a[0]); + break; case 2: - retval = syscall(a[0],a[1]); - break; + retval = syscall(a[0],a[1]); + break; case 3: - retval = syscall(a[0],a[1],a[2]); - break; + retval = syscall(a[0],a[1],a[2]); + break; case 4: - retval = syscall(a[0],a[1],a[2],a[3]); - break; + retval = syscall(a[0],a[1],a[2],a[3]); + break; case 5: - retval = syscall(a[0],a[1],a[2],a[3],a[4]); - break; + retval = syscall(a[0],a[1],a[2],a[3],a[4]); + break; case 6: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]); - break; + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]); + break; case 7: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]); - break; + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]); + break; case 8: - retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]); - break; + retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]); + break; } SP = ORIGMARK; PUSHi(retval); @@ -5759,24 +5759,24 @@ fcntl_emulate_flock(int fd, int operation) switch (operation & ~LOCK_NB) { case LOCK_SH: - flock.l_type = F_RDLCK; - break; + flock.l_type = F_RDLCK; + break; case LOCK_EX: - flock.l_type = F_WRLCK; - break; + flock.l_type = F_WRLCK; + break; case LOCK_UN: - flock.l_type = F_UNLCK; - break; + flock.l_type = F_UNLCK; + break; default: - errno = EINVAL; - return -1; + errno = EINVAL; + return -1; } flock.l_whence = SEEK_SET; flock.l_start = flock.l_len = (Off_t)0; res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock); if (res == -1 && ((errno == EAGAIN) || (errno == EACCES))) - errno = EWOULDBLOCK; + errno = EWOULDBLOCK; return res; } @@ -5822,44 +5822,44 @@ lockf_emulate_flock(int fd, int operation) /* flock locks entire file so for lockf we need to do the same */ pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */ if (pos > 0) /* is seekable and needs to be repositioned */ - if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0) - pos = -1; /* seek failed, so don't seek back afterwards */ + if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0) + pos = -1; /* seek failed, so don't seek back afterwards */ RESTORE_ERRNO; switch (operation) { - /* LOCK_SH - get a shared lock */ - case LOCK_SH: - /* LOCK_EX - get an exclusive lock */ - case LOCK_EX: - i = lockf (fd, F_LOCK, 0); - break; - - /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */ - case LOCK_SH|LOCK_NB: - /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */ - case LOCK_EX|LOCK_NB: - i = lockf (fd, F_TLOCK, 0); - if (i == -1) - if ((errno == EAGAIN) || (errno == EACCES)) - errno = EWOULDBLOCK; - break; - - /* LOCK_UN - unlock (non-blocking is a no-op) */ - case LOCK_UN: - case LOCK_UN|LOCK_NB: - i = lockf (fd, F_ULOCK, 0); - break; - - /* Default - can't decipher operation */ - default: - i = -1; - errno = EINVAL; - break; + /* LOCK_SH - get a shared lock */ + case LOCK_SH: + /* LOCK_EX - get an exclusive lock */ + case LOCK_EX: + i = lockf (fd, F_LOCK, 0); + break; + + /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */ + case LOCK_SH|LOCK_NB: + /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */ + case LOCK_EX|LOCK_NB: + i = lockf (fd, F_TLOCK, 0); + if (i == -1) + if ((errno == EAGAIN) || (errno == EACCES)) + errno = EWOULDBLOCK; + break; + + /* LOCK_UN - unlock (non-blocking is a no-op) */ + case LOCK_UN: + case LOCK_UN|LOCK_NB: + i = lockf (fd, F_ULOCK, 0); + break; + + /* Default - can't decipher operation */ + default: + i = -1; + errno = EINVAL; + break; } if (pos > 0) /* need to restore position of the handle */ - PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */ + PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */ return (i); } @@ -5,7 +5,7 @@ /* Return default value and print no error message */ int matherr( struct exception *err ) { - return 1; + return 1; } #endif @@ -224,11 +224,11 @@ struct RExC_state_t { regnode *end_op; /* END node in program */ I32 utf8; /* whether the pattern is utf8 or not */ I32 orig_utf8; /* whether the pattern was originally in utf8 */ - /* XXX use this for future optimisation of case - * where pattern must be upgraded to utf8. */ + /* XXX use this for future optimisation of case + * where pattern must be upgraded to utf8. */ I32 uni_semantics; /* If a d charset modifier should use unicode - rules, even if the pattern is not in - utf8 */ + rules, even if the pattern is not in + utf8 */ I32 recurse_count; /* Number of recurse regops we have generated */ regnode **recurse; /* Recurse regops */ @@ -242,7 +242,7 @@ struct RExC_state_t { I32 in_multi_char_class; int code_index; /* next code_blocks[] slot */ struct reg_code_blocks *code_blocks;/* positions of literal (?{}) - within pattern */ + within pattern */ SSize_t maxlen; /* mininum possible number of chars in string to match */ scan_frame *frame_head; scan_frame *frame_last; @@ -801,23 +801,23 @@ static const scan_data_t zero_scan_data = { #define _FAIL(code) STMT_START { \ const char *ellipses = ""; \ IV len = RExC_precomp_end - RExC_precomp; \ - \ + \ PREPARE_TO_DIE; \ if (len > RegexLengthToShowInErrorMessages) { \ - /* chop 10 shorter than the max, to ensure meaning of "..." */ \ - len = RegexLengthToShowInErrorMessages - 10; \ - ellipses = "..."; \ + /* chop 10 shorter than the max, to ensure meaning of "..." */ \ + len = RegexLengthToShowInErrorMessages - 10; \ + ellipses = "..."; \ } \ code; \ } STMT_END #define FAIL(msg) _FAIL( \ Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/", \ - msg, UTF8fARG(UTF, len, RExC_precomp), ellipses)) + msg, UTF8fARG(UTF, len, RExC_precomp), ellipses)) #define FAIL2(msg,arg) _FAIL( \ Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/", \ - arg, UTF8fARG(UTF, len, RExC_precomp), ellipses)) + arg, UTF8fARG(UTF, len, RExC_precomp), ellipses)) #define FAIL3(msg,arg1,arg2) _FAIL( \ Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/", \ @@ -828,7 +828,7 @@ static const scan_data_t zero_scan_data = { */ #define Simple_vFAIL(m) STMT_START { \ Perl_croak(aTHX_ "%s" REPORT_LOCATION, \ - m, REPORT_LOCATION_ARGS(RExC_parse)); \ + m, REPORT_LOCATION_ARGS(RExC_parse)); \ } STMT_END /* @@ -861,7 +861,7 @@ static const scan_data_t zero_scan_data = { */ #define Simple_vFAIL3(m, a1, a2) STMT_START { \ S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, a2, \ - REPORT_LOCATION_ARGS(RExC_parse)); \ + REPORT_LOCATION_ARGS(RExC_parse)); \ } STMT_END /* @@ -877,7 +877,7 @@ static const scan_data_t zero_scan_data = { */ #define Simple_vFAIL4(m, a1, a2, a3) STMT_START { \ S_re_croak(aTHX_ UTF, m REPORT_LOCATION, a1, a2, a3, \ - REPORT_LOCATION_ARGS(RExC_parse)); \ + REPORT_LOCATION_ARGS(RExC_parse)); \ } STMT_END #define vFAIL4(m,a1,a2,a3) STMT_START { \ @@ -968,7 +968,7 @@ static const scan_data_t zero_scan_data = { _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - REPORT_LOCATION_ARGS(loc))) + REPORT_LOCATION_ARGS(loc))) #define vWARN(loc, m) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ @@ -980,26 +980,26 @@ static const scan_data_t zero_scan_data = { _WARN_HELPER(loc, packWARN(WARN_DEPRECATED), \ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), \ m REPORT_LOCATION, \ - REPORT_LOCATION_ARGS(loc))) + REPORT_LOCATION_ARGS(loc))) #define ckWARNdep(loc,m) \ _WARN_HELPER(loc, packWARN(WARN_DEPRECATED), \ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \ - m REPORT_LOCATION, \ - REPORT_LOCATION_ARGS(loc))) + m REPORT_LOCATION, \ + REPORT_LOCATION_ARGS(loc))) #define ckWARNregdep(loc,m) \ _WARN_HELPER(loc, packWARN2(WARN_DEPRECATED, WARN_REGEXP), \ Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, \ WARN_REGEXP), \ - m REPORT_LOCATION, \ - REPORT_LOCATION_ARGS(loc))) + m REPORT_LOCATION, \ + REPORT_LOCATION_ARGS(loc))) #define ckWARN2reg_d(loc,m, a1) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP), \ - m REPORT_LOCATION, \ - a1, REPORT_LOCATION_ARGS(loc))) + m REPORT_LOCATION, \ + a1, REPORT_LOCATION_ARGS(loc))) #define ckWARN2reg(loc, m, a1) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ @@ -1011,34 +1011,34 @@ static const scan_data_t zero_scan_data = { _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - a1, a2, REPORT_LOCATION_ARGS(loc))) + a1, a2, REPORT_LOCATION_ARGS(loc))) #define ckWARN3reg(loc, m, a1, a2) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - a1, a2, \ + a1, a2, \ REPORT_LOCATION_ARGS(loc))) #define vWARN4(loc, m, a1, a2, a3) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - a1, a2, a3, \ + a1, a2, a3, \ REPORT_LOCATION_ARGS(loc))) #define ckWARN4reg(loc, m, a1, a2, a3) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - a1, a2, a3, \ + a1, a2, a3, \ REPORT_LOCATION_ARGS(loc))) #define vWARN5(loc, m, a1, a2, a3, a4) \ _WARN_HELPER(loc, packWARN(WARN_REGEXP), \ Perl_warner(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ - a1, a2, a3, a4, \ + a1, a2, a3, a4, \ REPORT_LOCATION_ARGS(loc))) #define ckWARNexperimental(loc, class, m) \ @@ -1080,14 +1080,14 @@ static const scan_data_t zero_scan_data = { #define ProgLen(ri) ri->u.offsets[0] #define SetProgLen(ri,x) ri->u.offsets[0] = x #define Set_Node_Offset_To_R(offset,byte) STMT_START { \ - MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \ - __LINE__, (int)(offset), (int)(byte))); \ - if((offset) < 0) { \ - Perl_croak(aTHX_ "value of node is %d in Offset macro", \ + MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \ + __LINE__, (int)(offset), (int)(byte))); \ + if((offset) < 0) { \ + Perl_croak(aTHX_ "value of node is %d in Offset macro", \ (int)(offset)); \ - } else { \ + } else { \ RExC_offsets[2*(offset)-1] = (byte); \ - } \ + } \ } STMT_END #define Set_Node_Offset(node,byte) \ @@ -1095,14 +1095,14 @@ static const scan_data_t zero_scan_data = { #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse) #define Set_Node_Length_To_R(node,len) STMT_START { \ - MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \ - __LINE__, (int)(node), (int)(len))); \ - if((node) < 0) { \ - Perl_croak(aTHX_ "value of node is %d in Length macro", \ + MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \ + __LINE__, (int)(node), (int)(len))); \ + if((node) < 0) { \ + Perl_croak(aTHX_ "value of node is %d in Length macro", \ (int)(node)); \ - } else { \ - RExC_offsets[2*(node)] = (len); \ - } \ + } else { \ + RExC_offsets[2*(node)] = (len); \ + } \ } STMT_END #define Set_Node_Length(node,len) \ @@ -1476,13 +1476,13 @@ S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) { const U8 i = data->cur_is_floating; - SvSetMagicSV(longest_sv, data->last_found); + SvSetMagicSV(longest_sv, data->last_found); data->substrs[i].min_offset = l ? data->last_start_min : data->pos_min; - if (!i) /* fixed */ - data->substrs[0].max_offset = data->substrs[0].min_offset; - else { /* float */ - data->substrs[1].max_offset = + if (!i) /* fixed */ + data->substrs[0].max_offset = data->substrs[0].min_offset; + else { /* float */ + data->substrs[1].max_offset = (is_inf) ? OPTIMIZE_INFTY : (l @@ -1490,8 +1490,8 @@ S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, /* temporary underflow guard for 5.32 */ : data->pos_delta < 0 ? OPTIMIZE_INFTY : (data->pos_delta > OPTIMIZE_INFTY - data->pos_min - ? OPTIMIZE_INFTY - : data->pos_min + data->pos_delta)); + ? OPTIMIZE_INFTY + : data->pos_min + data->pos_delta)); } data->substrs[i].flags &= ~SF_BEFORE_EOL; @@ -1502,12 +1502,12 @@ S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, SvCUR_set(data->last_found, 0); { - SV * const sv = data->last_found; - if (SvUTF8(sv) && SvMAGICAL(sv)) { - MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8); - if (mg) - mg->mg_len = 0; - } + SV * const sv = data->last_found; + if (SvUTF8(sv) && SvMAGICAL(sv)) { + MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8); + if (mg) + mg->mg_len = 0; + } } data->last_end = -1; data->flags &= ~SF_BEFORE_EOL; @@ -1596,10 +1596,10 @@ S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc) * test cases for locale, many parts of it may not work properly, it is * safest to avoid locale unless necessary. */ if (RExC_contains_locale) { - ANYOF_POSIXL_SETALL(ssc); + ANYOF_POSIXL_SETALL(ssc); } else { - ANYOF_POSIXL_ZERO(ssc); + ANYOF_POSIXL_ZERO(ssc); } } @@ -2254,7 +2254,7 @@ S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc) STATIC void S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, - AV *revcharmap, U32 depth) + AV *revcharmap, U32 depth) { U32 state; SV *sv=sv_newmortal(); @@ -2268,14 +2268,14 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, depth+1, "Match","Base","Ofs" ); for( state = 0 ; state < trie->uniquecharcount ; state++ ) { - SV ** const tmp = av_fetch( revcharmap, state, 0); + SV ** const tmp = av_fetch( revcharmap, state, 0); if ( tmp ) { Perl_re_printf( aTHX_ "%*s", colwidth, pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, - PL_colors[0], PL_colors[1], - (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | - PERL_PV_ESCAPE_FIRSTCHAR + PL_colors[0], PL_colors[1], + (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | + PERL_PV_ESCAPE_FIRSTCHAR ) ); } @@ -2288,7 +2288,7 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, Perl_re_printf( aTHX_ "\n"); for( state = 1 ; state < trie->statecount ; state++ ) { - const U32 base = trie->states[ state ].trans.base; + const U32 base = trie->states[ state ].trans.base; Perl_re_indentf( aTHX_ "#%4" UVXf "|", depth+1, (UV)state); @@ -2335,8 +2335,8 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, depth); for (word=1; word <= trie->wordcount; word++) { Perl_re_printf( aTHX_ " %d:(%d,%d)", - (int)word, (int)(trie->wordinfo[word].prev), - (int)(trie->wordinfo[word].len)); + (int)word, (int)(trie->wordinfo[word].prev), + (int)(trie->wordinfo[word].len)); } Perl_re_printf( aTHX_ "\n" ); } @@ -2348,8 +2348,8 @@ S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, */ STATIC void S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, - HV *widecharmap, AV *revcharmap, U32 next_alloc, - U32 depth) + HV *widecharmap, AV *revcharmap, U32 next_alloc, + U32 depth) { U32 state; SV *sv=sv_newmortal(); @@ -2377,9 +2377,9 @@ S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, ); } for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) { - SV ** const tmp = av_fetch( revcharmap, + SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state, charid).forid, 0); - if ( tmp ) { + if ( tmp ) { Perl_re_printf( aTHX_ "%*s:%3X=%4" UVXf " | ", colwidth, pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), @@ -2408,8 +2408,8 @@ S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, */ STATIC void S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, - HV *widecharmap, AV *revcharmap, U32 next_alloc, - U32 depth) + HV *widecharmap, AV *revcharmap, U32 next_alloc, + U32 depth) { U32 state; U16 charid; @@ -2427,14 +2427,14 @@ S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, Perl_re_indentf( aTHX_ "Char : ", depth+1 ); for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) { - SV ** const tmp = av_fetch( revcharmap, charid, 0); + SV ** const tmp = av_fetch( revcharmap, charid, 0); if ( tmp ) { Perl_re_printf( aTHX_ "%*s", colwidth, pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, - PL_colors[0], PL_colors[1], - (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | - PERL_PV_ESCAPE_FIRSTCHAR + PL_colors[0], PL_colors[1], + (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | + PERL_PV_ESCAPE_FIRSTCHAR ) ); } @@ -2479,9 +2479,9 @@ S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, /* make_trie(startbranch,first,last,tail,word_count,flags,depth) startbranch: the first branch in the whole branch sequence first : start branch of sequence of branch-exact nodes. - May be the same as startbranch + May be the same as startbranch last : Thing following the last branch. - May be the same as tail. + May be the same as tail. tail : item following the branch sequence count : words in the sequence flags : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/ @@ -2557,10 +2557,10 @@ and should turn into: 1: CURLYM[1] {1,32767}(18) 5: TRIE(16) - [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1] - <ac> - <ad> - <ab> + [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1] + <ac> + <ad> + <ab> 16: SUCCEED(0) 17: NOTHING(18) 18: END(0) @@ -2580,8 +2580,8 @@ and would end up looking like: 1: TRIE(8) [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1] - <foo> - <bar> + <foo> + <bar> 7: TAIL(8) 8: EXACT <baz>(10) 10: END(0) @@ -2595,19 +2595,19 @@ is the recommended Unicode-aware way of saying #define TRIE_STORE_REVCHAR(val) \ STMT_START { \ - if (UTF) { \ + if (UTF) { \ SV *zlopp = newSV(UTF8_MAXBYTES); \ - unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \ + unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \ unsigned char *const kapow = uvchr_to_utf8(flrbbbbb, val); \ *kapow = '\0'; \ - SvCUR_set(zlopp, kapow - flrbbbbb); \ - SvPOK_on(zlopp); \ - SvUTF8_on(zlopp); \ - av_push(revcharmap, zlopp); \ - } else { \ + SvCUR_set(zlopp, kapow - flrbbbbb); \ + SvPOK_on(zlopp); \ + SvUTF8_on(zlopp); \ + av_push(revcharmap, zlopp); \ + } else { \ char ooooff = (char)val; \ - av_push(revcharmap, newSVpvn(&ooooff, 1)); \ - } \ + av_push(revcharmap, newSVpvn(&ooooff, 1)); \ + } \ } STMT_END /* This gets the next character from the input, folding it if not already @@ -2638,8 +2638,8 @@ is the recommended Unicode-aware way of saying #define TRIE_LIST_PUSH(state,fid,ns) STMT_START { \ if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) { \ - U32 ging = TRIE_LIST_LEN( state ) * 2; \ - Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \ + U32 ging = TRIE_LIST_LEN( state ) * 2; \ + Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \ TRIE_LIST_LEN( state ) = ging; \ } \ TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid; \ @@ -2649,7 +2649,7 @@ is the recommended Unicode-aware way of saying #define TRIE_LIST_NEW(state) STMT_START { \ Newx( trie->states[ state ].trans.list, \ - 4, reg_trie_trans_le ); \ + 4, reg_trie_trans_le ); \ TRIE_LIST_CUR( state ) = 1; \ TRIE_LIST_LEN( state ) = 4; \ } STMT_END @@ -2688,8 +2688,8 @@ is the recommended Unicode-aware way of saying /* It's a dupe. Pre-insert into the wordinfo[].prev */\ /* chain, so that when the bits of chain are later */\ /* linked together, the dups appear in the chain */\ - trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \ - trie->wordinfo[dupe].prev = curword; \ + trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \ + trie->wordinfo[dupe].prev = curword; \ } else { \ /* we haven't inserted this word yet. */ \ trie->states[ state ].wordnum = curword; \ @@ -2769,11 +2769,11 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, switch (flags) { case EXACT: case EXACT_REQ8: case EXACTL: break; - case EXACTFAA: + case EXACTFAA: case EXACTFUP: - case EXACTFU: - case EXACTFLU8: folder = PL_fold_latin1; break; - case EXACTF: folder = PL_fold; break; + case EXACTFU: + case EXACTFLU8: folder = PL_fold_latin1; break; + case EXACTF: folder = PL_fold; break; default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] ); } @@ -2784,7 +2784,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, RExC_rxi->data->data[ data_slot ] = (void*)trie; trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) ); if (flags == EXACT || flags == EXACT_REQ8 || flags == EXACTL) - trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 ); + trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 ); trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc( trie->wordcount+1, sizeof(reg_trie_wordinfo)); @@ -2964,8 +2964,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, TRIE_STORE_REVCHAR( uvc ); } if ( set_bit ) { - /* store the codepoint in the bitmap, and its folded - * equivalent. */ + /* store the codepoint in the bitmap, and its folded + * equivalent. */ TRIE_BITMAP_SET_FOLDED(trie, uvc, folder); set_bit = 0; /* We've done our bit :-) */ } @@ -3010,8 +3010,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n", depth+1, ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count, - (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount, - (int)trie->minlen, (int)trie->maxlen ) + (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount, + (int)trie->minlen, (int)trie->maxlen ) ); /* @@ -3059,17 +3059,17 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_ "Compiling trie using list compiler\n", depth+1)); - trie->states = (reg_trie_state *) - PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, - sizeof(reg_trie_state) ); + trie->states = (reg_trie_state *) + PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, + sizeof(reg_trie_state) ); TRIE_LIST_NEW(1); next_alloc = 2; for ( cur = first ; cur < last ; cur = regnext( cur ) ) { regnode *noper = NEXTOPER( cur ); - U32 state = 1; /* required init */ - U16 charid = 0; /* sanity init */ + U32 state = 1; /* required init */ + U16 charid = 0; /* sanity init */ U32 wordlen = 0; /* required init */ if (OP(noper) == NOTHING) { @@ -3096,7 +3096,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, if ( uvc < 256 ) { charid = trie->charmap[ uvc ]; - } else { + } else { SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), @@ -3106,7 +3106,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, } else { charid=(U16)SvIV( *svpp ); } - } + } /* charid is now 0 if we dont know the char read, or * nonzero if we do */ if ( charid ) { @@ -3117,7 +3117,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, charid--; if ( !trie->states[ state ].trans.list ) { TRIE_LIST_NEW( state ); - } + } for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) @@ -3131,15 +3131,15 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, } if ( ! newstate ) { newstate = next_alloc++; - prev_states[newstate] = state; + prev_states[newstate] = state; TRIE_LIST_PUSH( state, charid, newstate ); transcount++; } state = newstate; } else { Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc ); - } - } + } + } } else { /* If we end up here it is because we skipped past a NOTHING, but did not end up * on a trieable type. So we need to reset noper back to point at the first regop @@ -3154,18 +3154,18 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, /* next alloc is the NEXT state to be allocated */ trie->statecount = next_alloc; trie->states = (reg_trie_state *) - PerlMemShared_realloc( trie->states, - next_alloc - * sizeof(reg_trie_state) ); + PerlMemShared_realloc( trie->states, + next_alloc + * sizeof(reg_trie_state) ); /* and now dump it out before we compress it */ DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap, - revcharmap, next_alloc, - depth+1) + revcharmap, next_alloc, + depth+1) ); trie->trans = (reg_trie_trans *) - PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) ); + PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) ); { U32 state; U32 tp = 0; @@ -3184,22 +3184,22 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, if (trie->states[state].trans.list) { U16 minid=TRIE_LIST_ITEM( state, 1).forid; U16 maxid=minid; - U16 idx; + U16 idx; for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) { - const U16 forid = TRIE_LIST_ITEM( state, idx).forid; - if ( forid < minid ) { - minid=forid; - } else if ( forid > maxid ) { - maxid=forid; - } + const U16 forid = TRIE_LIST_ITEM( state, idx).forid; + if ( forid < minid ) { + minid=forid; + } else if ( forid > maxid ) { + maxid=forid; + } } if ( transcount < tp + maxid - minid + 1) { transcount *= 2; - trie->trans = (reg_trie_trans *) - PerlMemShared_realloc( trie->trans, - transcount - * sizeof(reg_trie_trans) ); + trie->trans = (reg_trie_trans *) + PerlMemShared_realloc( trie->trans, + transcount + * sizeof(reg_trie_trans) ); Zero( trie->trans + (transcount / 2), transcount / 2, reg_trie_trans ); @@ -3285,13 +3285,13 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_ "Compiling trie using table compiler\n", depth+1)); - trie->trans = (reg_trie_trans *) - PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 ) - * trie->uniquecharcount + 1, - sizeof(reg_trie_trans) ); + trie->trans = (reg_trie_trans *) + PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 ) + * trie->uniquecharcount + 1, + sizeof(reg_trie_trans) ); trie->states = (reg_trie_state *) - PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, - sizeof(reg_trie_state) ); + PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2, + sizeof(reg_trie_state) ); next_alloc = trie->uniquecharcount + 1; @@ -3342,8 +3342,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, if ( !trie->trans[ state + charid ].next ) { trie->trans[ state + charid ].next = next_alloc; trie->trans[ state ].check++; - prev_states[TRIE_NODENUM(next_alloc)] - = TRIE_NODENUM(state); + prev_states[TRIE_NODENUM(next_alloc)] + = TRIE_NODENUM(state); next_alloc += trie->uniquecharcount; } state = trie->trans[ state + charid ].next; @@ -3367,8 +3367,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, /* and now dump it out before we compress it */ DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap, - revcharmap, - next_alloc, depth+1)); + revcharmap, + next_alloc, depth+1)); { /* @@ -3433,15 +3433,15 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, demq */ const U32 laststate = TRIE_NODENUM( next_alloc ); - U32 state, charid; + U32 state, charid; U32 pos = 0, zp=0; trie->statecount = laststate; for ( state = 1 ; state < laststate ; state++ ) { U8 flag = 0; - const U32 stateidx = TRIE_NODEIDX( state ); - const U32 o_used = trie->trans[ stateidx ].check; - U32 used = trie->trans[ stateidx ].check; + const U32 stateidx = TRIE_NODEIDX( state ); + const U32 o_used = trie->trans[ stateidx ].check; + U32 used = trie->trans[ stateidx ].check; trie->trans[ stateidx ].check = 0; for ( charid = 0; @@ -3484,8 +3484,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, } trie->lasttrans = pos + 1; trie->states = (reg_trie_state *) - PerlMemShared_realloc( trie->states, laststate - * sizeof(reg_trie_state) ); + PerlMemShared_realloc( trie->states, laststate + * sizeof(reg_trie_state) ); DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_ "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n", depth+1, @@ -3506,8 +3506,8 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, ); /* resize the trans array to remove unused space */ trie->trans = (reg_trie_trans *) - PerlMemShared_realloc( trie->trans, trie->lasttrans - * sizeof(reg_trie_trans) ); + PerlMemShared_realloc( trie->trans, trie->lasttrans + * sizeof(reg_trie_trans) ); { /* Modify the program and insert the new TRIE node */ U8 nodetype =(U8)(flags & 0xFF); @@ -3602,20 +3602,20 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, (UV)state)); if (first_ofs >= 0) { SV ** const tmp = av_fetch( revcharmap, first_ofs, 0); - const U8 * const ch = (U8*)SvPV_nolen_const( *tmp ); + const U8 * const ch = (U8*)SvPV_nolen_const( *tmp ); TRIE_BITMAP_SET_FOLDED(trie,*ch, folder); DEBUG_OPTIMISE_r( Perl_re_printf( aTHX_ "%s", (char*)ch) ); - } - } + } + } /* store the current firstchar in the bitmap */ TRIE_BITMAP_SET_FOLDED(trie,*ch, folder); DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch)); - } + } first_ofs = ofs; - } + } } if ( count == 1 ) { /* This state has only one transition, its transition is part @@ -3630,9 +3630,9 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, depth+1, (UV)state, (UV)first_ofs, pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, - PL_colors[0], PL_colors[1], - (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | - PERL_PV_ESCAPE_FIRSTCHAR + PL_colors[0], PL_colors[1], + (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) | + PERL_PV_ESCAPE_FIRSTCHAR ) ); }); @@ -3645,15 +3645,15 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, setSTR_LEN(convert, (U8)(STR_LEN(convert) + len)); while (len--) *str++ = *ch++; - } else { + } else { #ifdef DEBUGGING - if (state>1) + if (state>1) DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n")); #endif - break; - } - } - trie->prefixlen = (state-1); + break; + } + } + trie->prefixlen = (state-1); if (str) { regnode *n = convert+NODE_SZ_STR(convert); assert( NODE_SZ_STR(convert) <= U16_MAX ); @@ -3694,7 +3694,7 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, #endif if (trie->maxlen) { convert = n; - } else { + } else { NEXT_OFF(convert) = (U16)(tail - convert); DEBUG_r(optimize= n); } @@ -3703,23 +3703,23 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, if (!jumper) jumper = last; if ( trie->maxlen ) { - NEXT_OFF( convert ) = (U16)(tail - convert); - ARG_SET( convert, data_slot ); - /* Store the offset to the first unabsorbed branch in - jump[0], which is otherwise unused by the jump logic. - We use this when dumping a trie and during optimisation. */ - if (trie->jump) - trie->jump[0] = (U16)(nextbranch - convert); + NEXT_OFF( convert ) = (U16)(tail - convert); + ARG_SET( convert, data_slot ); + /* Store the offset to the first unabsorbed branch in + jump[0], which is otherwise unused by the jump logic. + We use this when dumping a trie and during optimisation. */ + if (trie->jump) + trie->jump[0] = (U16)(nextbranch - convert); /* If the start state is not accepting (meaning there is no empty string/NOTHING) - * and there is a bitmap - * and the first "jump target" node we found leaves enough room - * then convert the TRIE node into a TRIEC node, with the bitmap - * embedded inline in the opcode - this is hypothetically faster. - */ + * and there is a bitmap + * and the first "jump target" node we found leaves enough room + * then convert the TRIE node into a TRIEC node, with the bitmap + * embedded inline in the opcode - this is hypothetically faster. + */ if ( !trie->states[trie->startstate].wordnum - && trie->bitmap - && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) ) + && trie->bitmap + && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) ) { OP( convert ) = TRIEC; Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char); @@ -3768,26 +3768,26 @@ S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, * already linked up earlier. */ { - U16 word; - U32 state; - U16 prev; - - for (word=1; word <= trie->wordcount; word++) { - prev = 0; - if (trie->wordinfo[word].prev) - continue; - state = trie->wordinfo[word].accept; - while (state) { - state = prev_states[state]; - if (!state) - break; - prev = trie->states[state].wordnum; - if (prev) - break; - } - trie->wordinfo[word].prev = prev; - } - Safefree(prev_states); + U16 word; + U32 state; + U16 prev; + + for (word=1; word <= trie->wordcount; word++) { + prev = 0; + if (trie->wordinfo[word].prev) + continue; + state = trie->wordinfo[word].accept; + while (state) { + state = prev_states[state]; + if (!state) + break; + prev = trie->states[state].wordnum; + if (prev) + break; + } + trie->wordinfo[word].prev = prev; + } + Safefree(prev_states); } @@ -3884,20 +3884,20 @@ S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *sour fail[ 0 ] = fail[ 1 ] = 1; for ( charid = 0; charid < ucharcount ; charid++ ) { - const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 ); - if ( newstate ) { + const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 ); + if ( newstate ) { q[ q_write ] = newstate; /* set to point at the root */ fail[ q[ q_write++ ] ]=1; } } while ( q_read < q_write) { - const U32 cur = q[ q_read++ % numstates ]; + const U32 cur = q[ q_read++ % numstates ]; base = trie->states[ cur ].trans.base; for ( charid = 0 ; charid < ucharcount ; charid++ ) { - const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 ); - if (ch_state) { + const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 ); + if (ch_state) { U32 fail_state = cur; U32 fail_base; do { @@ -4259,16 +4259,16 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, } #ifdef EXPERIMENTAL_INPLACESCAN - if (flags && !NEXT_OFF(n)) { - DEBUG_PEEP("atch", val, depth, 0); - if (reg_off_by_arg[OP(n)]) { - ARG_SET(n, val - n); - } - else { - NEXT_OFF(n) = val - n; - } - stopnow = 1; - } + if (flags && !NEXT_OFF(n)) { + DEBUG_PEEP("atch", val, depth, 0); + if (reg_off_by_arg[OP(n)]) { + ARG_SET(n, val - n); + } + else { + NEXT_OFF(n) = val - n; + } + stopnow = 1; + } #endif } @@ -4294,11 +4294,11 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, int total_count_delta = 0; /* Total delta number of characters that multi-char folds expand to */ - /* One pass is made over the node's string looking for all the - * possibilities. To avoid some tests in the loop, there are two main - * cases, for UTF-8 patterns (which can't have EXACTF nodes) and - * non-UTF-8 */ - if (UTF) { + /* One pass is made over the node's string looking for all the + * possibilities. To avoid some tests in the loop, there are two main + * cases, for UTF-8 patterns (which can't have EXACTF nodes) and + * non-UTF-8 */ + if (UTF) { U8* folded = NULL; if (OP(scan) == EXACTFL) { @@ -4355,7 +4355,7 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, * executed */ while (s < s_end - 1) /* Can stop 1 before the end, as minimum length sequence we are looking for is 2 */ - { + { int count = 0; /* How many characters in a multi-char fold */ int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end); if (! len) { /* Not a multi-char fold: get next char */ @@ -4391,7 +4391,7 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, * the character that folds to the sequence is) */ total_count_delta += count - 1; next_iteration: ; - } + } /* We created a temporary folded copy of the string in EXACTFL * nodes. Therefore we need to be sure it doesn't go below zero, @@ -4406,8 +4406,8 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, *min_subtract += total_count_delta; Safefree(folded); - } - else if (OP(scan) == EXACTFAA) { + } + else if (OP(scan) == EXACTFAA) { /* Non-UTF-8 pattern, EXACTFAA node. There can't be a multi-char * fold to the ASCII range (and there are no existing ones in the @@ -4418,7 +4418,7 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \ || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \ || UNICODE_DOT_DOT_VERSION > 0) - while (s < s_end) { + while (s < s_end) { if (*s == LATIN_SMALL_LETTER_SHARP_S) { OP(scan) = EXACTFAA_NO_TRIE; *unfolded_multi_char = TRUE; @@ -4427,7 +4427,7 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, s++; } } - else if (OP(scan) != EXACTFAA_NO_TRIE) { + else if (OP(scan) != EXACTFAA_NO_TRIE) { /* Non-UTF-8 pattern, not EXACTFAA node. Look for the multi-char * folds that are all Latin1. As explained in the comments @@ -4435,11 +4435,11 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, * and EXACTFL nodes; it can be in the final position. Otherwise * we can stop looking 1 byte earlier because have to find at least * two characters for a multi-fold */ - const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL) + const U8* upper = (OP(scan) == EXACTF || OP(scan) == EXACTFL) ? s_end : s_end -1; - while (s < upper) { + while (s < upper) { int len = is_MULTI_CHAR_FOLD_latin1_safe(s, s_end); if (! len) { /* Not a multi-char fold. */ if (*s == LATIN_SMALL_LETTER_SHARP_S @@ -4465,13 +4465,13 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, if (OP(scan) != EXACTF && OP(scan) != EXACTFL) { OP(scan) = EXACTFUP; } - } + } *min_subtract += len - 1; s += len; - } + } #endif - } + } } #ifdef DEBUGGING @@ -4479,9 +4479,9 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, * ops and/or strings with fake optimized ops */ n = scan + NODE_SZ_STR(scan); while (n <= stop) { - OP(n) = OPTIMIZED; - FLAGS(n) = 0; - NEXT_OFF(n) = 0; + OP(n) = OPTIMIZED; + FLAGS(n) = 0; + NEXT_OFF(n) = 0; n++; } #endif @@ -4552,19 +4552,19 @@ S_rck_elide_nothing(pTHX_ regnode *node) STATIC SSize_t S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, SSize_t *minlenp, SSize_t *deltap, - regnode *last, - scan_data_t *data, - I32 stopparen, + regnode *last, + scan_data_t *data, + I32 stopparen, U32 recursed_depth, - regnode_ssc *and_withp, - U32 flags, U32 depth, bool was_mutate_ok) - /* scanp: Start here (read-write). */ - /* deltap: Write maxlen-minlen here. */ - /* last: Stop before this one. */ - /* data: string data about the pattern */ - /* stopparen: treat close N as END */ - /* recursed: which subroutines have we recursed into */ - /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */ + regnode_ssc *and_withp, + U32 flags, U32 depth, bool was_mutate_ok) + /* scanp: Start here (read-write). */ + /* deltap: Write maxlen-minlen here. */ + /* last: Stop before this one. */ + /* data: string data about the pattern */ + /* stopparen: treat close N as END */ + /* recursed: which subroutines have we recursed into */ + /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */ { SSize_t final_minlen; /* There must be at least this number of characters to match */ @@ -4627,12 +4627,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, UV min_subtract = 0; /* How mmany chars to subtract from the minimum node length to get a real minimum (because the folded version may be shorter) */ - bool unfolded_multi_char = FALSE; + bool unfolded_multi_char = FALSE; /* avoid mutating ops if we are anywhere within the recursed or * enframed handling for a GOSUB: the outermost level will handle it. */ bool mutate_ok = was_mutate_ok && !(frame && frame->in_gosub); - /* Peephole optimizer: */ + /* Peephole optimizer: */ DEBUG_STUDYDATA("Peep", data, depth, is_inf); DEBUG_PEEP("Peep", scan, depth, flags); @@ -4690,21 +4690,21 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, OP(scan) == BRANCHJ || OP(scan) == IFTHEN ) { - next = regnext(scan); - code = OP(scan); + next = regnext(scan); + code = OP(scan); /* The op(next)==code check below is to see if we * have "BRANCH-BRANCH", "BRANCHJ-BRANCHJ", "IFTHEN-IFTHEN" * IFTHEN is special as it might not appear in pairs. * Not sure whether BRANCH-BRANCHJ is possible, regardless * we dont handle it cleanly. */ - if (OP(next) == code || code == IFTHEN) { + if (OP(next) == code || code == IFTHEN) { /* NOTE - There is similar code to this block below for * handling TRIE nodes on a re-study. If you change stuff here * check there too. */ - SSize_t max1 = 0, min1 = OPTIMIZE_INFTY, num = 0; - regnode_ssc accum; - regnode * const startbranch=scan; + SSize_t max1 = 0, min1 = OPTIMIZE_INFTY, num = 0; + regnode_ssc accum; + regnode * const startbranch=scan; if (flags & SCF_DO_SUBSTR) { /* Cannot merge strings after this. */ @@ -4712,164 +4712,164 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } if (flags & SCF_DO_STCLASS) - ssc_init_zero(pRExC_state, &accum); + ssc_init_zero(pRExC_state, &accum); - while (OP(scan) == code) { - SSize_t deltanext, minnext, fake; - I32 f = 0; - regnode_ssc this_class; + while (OP(scan) == code) { + SSize_t deltanext, minnext, fake; + I32 f = 0; + regnode_ssc this_class; DEBUG_PEEP("Branch", scan, depth, flags); - num++; + num++; StructCopy(&zero_scan_data, &data_fake, scan_data_t); - if (data) { - data_fake.whilem_c = data->whilem_c; - data_fake.last_closep = data->last_closep; - } - else - data_fake.last_closep = &fake; + if (data) { + data_fake.whilem_c = data->whilem_c; + data_fake.last_closep = data->last_closep; + } + else + data_fake.last_closep = &fake; - data_fake.pos_delta = delta; - next = regnext(scan); + data_fake.pos_delta = delta; + next = regnext(scan); scan = NEXTOPER(scan); /* everything */ if (code != BRANCH) /* everything but BRANCH */ - scan = NEXTOPER(scan); + scan = NEXTOPER(scan); - if (flags & SCF_DO_STCLASS) { - ssc_init(pRExC_state, &this_class); - data_fake.start_class = &this_class; - f = SCF_DO_STCLASS_AND; - } - if (flags & SCF_WHILEM_VISITED_POS) - f |= SCF_WHILEM_VISITED_POS; + if (flags & SCF_DO_STCLASS) { + ssc_init(pRExC_state, &this_class); + data_fake.start_class = &this_class; + f = SCF_DO_STCLASS_AND; + } + if (flags & SCF_WHILEM_VISITED_POS) + f |= SCF_WHILEM_VISITED_POS; - /* we suppose the run is continuous, last=next...*/ + /* we suppose the run is continuous, last=next...*/ /* recurse study_chunk() for each BRANCH in an alternation */ - minnext = study_chunk(pRExC_state, &scan, minlenp, + minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, next, &data_fake, stopparen, recursed_depth, NULL, f, depth+1, mutate_ok); - if (min1 > minnext) - min1 = minnext; - if (deltanext == OPTIMIZE_INFTY) { - is_inf = is_inf_internal = 1; - max1 = OPTIMIZE_INFTY; - } else if (max1 < minnext + deltanext) - max1 = minnext + deltanext; - scan = next; - if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) - pars++; - if (data_fake.flags & SCF_SEEN_ACCEPT) { - if ( stopmin > minnext) - stopmin = min + min1; - flags &= ~SCF_DO_SUBSTR; - if (data) - data->flags |= SCF_SEEN_ACCEPT; - } - if (data) { - if (data_fake.flags & SF_HAS_EVAL) - data->flags |= SF_HAS_EVAL; - data->whilem_c = data_fake.whilem_c; - } - if (flags & SCF_DO_STCLASS) - ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class); - } - if (code == IFTHEN && num < 2) /* Empty ELSE branch */ - min1 = 0; - if (flags & SCF_DO_SUBSTR) { - data->pos_min += min1; - if (data->pos_delta >= OPTIMIZE_INFTY - (max1 - min1)) - data->pos_delta = OPTIMIZE_INFTY; - else - data->pos_delta += max1 - min1; - if (max1 != min1 || is_inf) - data->cur_is_floating = 1; - } - min += min1; - if (delta == OPTIMIZE_INFTY - || OPTIMIZE_INFTY - delta - (max1 - min1) < 0) - delta = OPTIMIZE_INFTY; - else - delta += max1 - min1; - if (flags & SCF_DO_STCLASS_OR) { - ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum); - if (min1) { - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); - flags &= ~SCF_DO_STCLASS; - } - } - else if (flags & SCF_DO_STCLASS_AND) { - if (min1) { - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum); - flags &= ~SCF_DO_STCLASS; - } - else { - /* Switch to OR mode: cache the old value of - * data->start_class */ - INIT_AND_WITHP; - StructCopy(data->start_class, and_withp, regnode_ssc); - flags &= ~SCF_DO_STCLASS_AND; - StructCopy(&accum, data->start_class, regnode_ssc); - flags |= SCF_DO_STCLASS_OR; - } - } + if (min1 > minnext) + min1 = minnext; + if (deltanext == OPTIMIZE_INFTY) { + is_inf = is_inf_internal = 1; + max1 = OPTIMIZE_INFTY; + } else if (max1 < minnext + deltanext) + max1 = minnext + deltanext; + scan = next; + if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) + pars++; + if (data_fake.flags & SCF_SEEN_ACCEPT) { + if ( stopmin > minnext) + stopmin = min + min1; + flags &= ~SCF_DO_SUBSTR; + if (data) + data->flags |= SCF_SEEN_ACCEPT; + } + if (data) { + if (data_fake.flags & SF_HAS_EVAL) + data->flags |= SF_HAS_EVAL; + data->whilem_c = data_fake.whilem_c; + } + if (flags & SCF_DO_STCLASS) + ssc_or(pRExC_state, &accum, (regnode_charclass*)&this_class); + } + if (code == IFTHEN && num < 2) /* Empty ELSE branch */ + min1 = 0; + if (flags & SCF_DO_SUBSTR) { + data->pos_min += min1; + if (data->pos_delta >= OPTIMIZE_INFTY - (max1 - min1)) + data->pos_delta = OPTIMIZE_INFTY; + else + data->pos_delta += max1 - min1; + if (max1 != min1 || is_inf) + data->cur_is_floating = 1; + } + min += min1; + if (delta == OPTIMIZE_INFTY + || OPTIMIZE_INFTY - delta - (max1 - min1) < 0) + delta = OPTIMIZE_INFTY; + else + delta += max1 - min1; + if (flags & SCF_DO_STCLASS_OR) { + ssc_or(pRExC_state, data->start_class, (regnode_charclass*) &accum); + if (min1) { + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + flags &= ~SCF_DO_STCLASS; + } + } + else if (flags & SCF_DO_STCLASS_AND) { + if (min1) { + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &accum); + flags &= ~SCF_DO_STCLASS; + } + else { + /* Switch to OR mode: cache the old value of + * data->start_class */ + INIT_AND_WITHP; + StructCopy(data->start_class, and_withp, regnode_ssc); + flags &= ~SCF_DO_STCLASS_AND; + StructCopy(&accum, data->start_class, regnode_ssc); + flags |= SCF_DO_STCLASS_OR; + } + } if (PERL_ENABLE_TRIE_OPTIMISATION && OP(startbranch) == BRANCH && mutate_ok ) { - /* demq. + /* demq. Assuming this was/is a branch we are dealing with: 'scan' now points at the item that follows the branch sequence, whatever it is. We now start at the beginning of the sequence and look for subsequences of - BRANCH->EXACT=>x1 - BRANCH->EXACT=>x2 - tail + BRANCH->EXACT=>x1 + BRANCH->EXACT=>x2 + tail which would be constructed from a pattern like /A|LIST|OF|WORDS/ - If we can find such a subsequence we need to turn the first - element into a trie and then add the subsequent branch exact - strings to the trie. + If we can find such a subsequence we need to turn the first + element into a trie and then add the subsequent branch exact + strings to the trie. - We have two cases + We have two cases 1. patterns where the whole set of branches can be converted. - 2. patterns where only a subset can be converted. + 2. patterns where only a subset can be converted. - In case 1 we can replace the whole set with a single regop - for the trie. In case 2 we need to keep the start and end - branches so + In case 1 we can replace the whole set with a single regop + for the trie. In case 2 we need to keep the start and end + branches so - 'BRANCH EXACT; BRANCH EXACT; BRANCH X' - becomes BRANCH TRIE; BRANCH X; + 'BRANCH EXACT; BRANCH EXACT; BRANCH X' + becomes BRANCH TRIE; BRANCH X; - There is an additional case, that being where there is a - common prefix, which gets split out into an EXACT like node - preceding the TRIE node. + There is an additional case, that being where there is a + common prefix, which gets split out into an EXACT like node + preceding the TRIE node. - If x(1..n)==tail then we can do a simple trie, if not we make - a "jump" trie, such that when we match the appropriate word - we "jump" to the appropriate tail node. Essentially we turn - a nested if into a case structure of sorts. + If x(1..n)==tail then we can do a simple trie, if not we make + a "jump" trie, such that when we match the appropriate word + we "jump" to the appropriate tail node. Essentially we turn + a nested if into a case structure of sorts. - */ + */ - int made=0; - if (!re_trie_maxbuff) { - re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1); - if (!SvIOK(re_trie_maxbuff)) - sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT); - } + int made=0; + if (!re_trie_maxbuff) { + re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1); + if (!SvIOK(re_trie_maxbuff)) + sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT); + } if ( SvIV(re_trie_maxbuff)>=0 ) { regnode *cur; regnode *first = (regnode *)NULL; @@ -5005,8 +5005,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } Perl_re_printf( aTHX_ "(First==%d,Last==%d,Cur==%d,tt==%s,ntt==%s,nntt==%s)\n", REG_NODE_NUM(first), REG_NODE_NUM(prev), REG_NODE_NUM(cur), - PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] - ); + PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype] + ); }); /* Is noper a trieable nodetype that can be merged @@ -5029,15 +5029,15 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, * otherwise we update the end pointer. */ if ( !first ) { first = cur; - if ( noper_trietype == NOTHING ) { + if ( noper_trietype == NOTHING ) { #if !defined(DEBUGGING) && !defined(NOJUMPTRIE) - regnode * const noper_next = regnext( noper ); + regnode * const noper_next = regnext( noper ); U8 noper_next_type = (noper_next && noper_next < tail) ? OP(noper_next) : 0; - U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0; + U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0; #endif if ( noper_next_trietype ) { - trietype = noper_next_trietype; + trietype = noper_next_trietype; } else if (noper_next_type) { /* a NOTHING regop is 1 regop wide. * We need at least two for a trie @@ -5052,8 +5052,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, trietype = noper_trietype; prev = cur; } - if (first) - count++; + if (first) + count++; } /* end handle mergable triable node */ else { /* handle unmergable node - @@ -5156,12 +5156,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } /* TRIE_MAXBUF is non zero */ } /* do trie */ - } - else if ( code == BRANCHJ ) { /* single branch is optimized. */ - scan = NEXTOPER(NEXTOPER(scan)); - } else /* single branch is optimized. */ - scan = NEXTOPER(scan); - continue; + } + else if ( code == BRANCHJ ) { /* single branch is optimized. */ + scan = NEXTOPER(NEXTOPER(scan)); + } else /* single branch is optimized. */ + scan = NEXTOPER(scan); + continue; } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB) { I32 paren = 0; regnode *start = NULL; @@ -5249,12 +5249,12 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, flags &= ~SCF_DO_STCLASS; start= NULL; /* reset start so we dont recurse later on. */ - } + } } else { - paren = stopparen; + paren = stopparen; start = scan + 2; - end = regnext(scan); - } + end = regnext(scan); + } if (start) { scan_frame *newframe; assert(end); @@ -5285,73 +5285,73 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, DEBUG_STUDYDATA("frame-new", data, depth, is_inf); DEBUG_PEEP("fnew", scan, depth, flags); - frame = newframe; - scan = start; - stopparen = paren; - last = end; + frame = newframe; + scan = start; + stopparen = paren; + last = end; depth = depth + 1; recursed_depth= my_recursed_depth; - continue; - } - } - else if (PL_regkind[OP(scan)] == EXACT && ! isEXACTFish(OP(scan))) { - SSize_t bytelen = STR_LEN(scan), charlen; - UV uc; + continue; + } + } + else if (PL_regkind[OP(scan)] == EXACT && ! isEXACTFish(OP(scan))) { + SSize_t bytelen = STR_LEN(scan), charlen; + UV uc; assert(bytelen); - if (UTF) { - const U8 * const s = (U8*)STRING(scan); - uc = utf8_to_uvchr_buf(s, s + bytelen, NULL); - charlen = utf8_length(s, s + bytelen); - } else { - uc = *((U8*)STRING(scan)); + if (UTF) { + const U8 * const s = (U8*)STRING(scan); + uc = utf8_to_uvchr_buf(s, s + bytelen, NULL); + charlen = utf8_length(s, s + bytelen); + } else { + uc = *((U8*)STRING(scan)); charlen = bytelen; - } - min += charlen; - if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */ - /* The code below prefers earlier match for fixed - offset, later match for variable offset. */ - if (data->last_end == -1) { /* Update the start info. */ - data->last_start_min = data->pos_min; + } + min += charlen; + if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */ + /* The code below prefers earlier match for fixed + offset, later match for variable offset. */ + if (data->last_end == -1) { /* Update the start info. */ + data->last_start_min = data->pos_min; data->last_start_max = is_inf ? OPTIMIZE_INFTY : (data->pos_delta > OPTIMIZE_INFTY - data->pos_min) ? OPTIMIZE_INFTY : data->pos_min + data->pos_delta; - } - sv_catpvn(data->last_found, STRING(scan), bytelen); - if (UTF) - SvUTF8_on(data->last_found); - { - SV * const sv = data->last_found; - MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? - mg_find(sv, PERL_MAGIC_utf8) : NULL; - if (mg && mg->mg_len >= 0) - mg->mg_len += charlen; - } - data->last_end = data->pos_min + charlen; - data->pos_min += charlen; /* As in the first entry. */ - data->flags &= ~SF_BEFORE_EOL; - } + } + sv_catpvn(data->last_found, STRING(scan), bytelen); + if (UTF) + SvUTF8_on(data->last_found); + { + SV * const sv = data->last_found; + MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? + mg_find(sv, PERL_MAGIC_utf8) : NULL; + if (mg && mg->mg_len >= 0) + mg->mg_len += charlen; + } + data->last_end = data->pos_min + charlen; + data->pos_min += charlen; /* As in the first entry. */ + data->flags &= ~SF_BEFORE_EOL; + } /* ANDing the code point leaves at most it, and not in locale, and * can't match null string */ - if (flags & SCF_DO_STCLASS_AND) { + if (flags & SCF_DO_STCLASS_AND) { ssc_cp_and(data->start_class, uc); ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; ssc_clear_locale(data->start_class); - } - else if (flags & SCF_DO_STCLASS_OR) { + } + else if (flags & SCF_DO_STCLASS_OR) { ssc_add_cp(data->start_class, uc); - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; - } - flags &= ~SCF_DO_STCLASS; - } + } + flags &= ~SCF_DO_STCLASS; + } else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT!, so is EXACTFish */ - SSize_t bytelen = STR_LEN(scan), charlen; + SSize_t bytelen = STR_LEN(scan), charlen; const U8 * s = (U8*)STRING(scan); /* Replace a length 1 ASCII fold pair node with an ANYOFM node, @@ -5374,28 +5374,28 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, continue; } - /* Search for fixed substrings supports EXACT only. */ - if (flags & SCF_DO_SUBSTR) { - assert(data); + /* Search for fixed substrings supports EXACT only. */ + if (flags & SCF_DO_SUBSTR) { + assert(data); scan_commit(pRExC_state, data, minlenp, is_inf); - } + } charlen = UTF ? (SSize_t) utf8_length(s, s + bytelen) : bytelen; - if (unfolded_multi_char) { + if (unfolded_multi_char) { RExC_seen |= REG_UNFOLDED_MULTI_SEEN; - } - min += charlen - min_subtract; + } + min += charlen - min_subtract; assert (min >= 0); delta += min_subtract; - if (flags & SCF_DO_SUBSTR) { - data->pos_min += charlen - min_subtract; - if (data->pos_min < 0) { + if (flags & SCF_DO_SUBSTR) { + data->pos_min += charlen - min_subtract; + if (data->pos_min < 0) { data->pos_min = 0; } data->pos_delta += min_subtract; - if (min_subtract) { - data->cur_is_floating = 1; /* float */ - } - } + if (min_subtract) { + data->cur_is_floating = 1; /* float */ + } + } if (flags & SCF_DO_STCLASS) { SV* EXACTF_invlist = make_exactf_invlist(pRExC_state, scan); @@ -5418,41 +5418,41 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, flags &= ~SCF_DO_STCLASS; SvREFCNT_dec(EXACTF_invlist); } - } - else if (REGNODE_VARIES(OP(scan))) { - SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0; - I32 fl = 0, f = flags; - regnode * const oscan = scan; - regnode_ssc this_class; - regnode_ssc *oclass = NULL; - I32 next_is_eval = 0; - - switch (PL_regkind[OP(scan)]) { - case WHILEM: /* End of (?:...)* . */ - scan = NEXTOPER(scan); - goto finish; - case PLUS: - if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) { - next = NEXTOPER(scan); - if ( ( PL_regkind[OP(next)] == EXACT + } + else if (REGNODE_VARIES(OP(scan))) { + SSize_t mincount, maxcount, minnext, deltanext, pos_before = 0; + I32 fl = 0, f = flags; + regnode * const oscan = scan; + regnode_ssc this_class; + regnode_ssc *oclass = NULL; + I32 next_is_eval = 0; + + switch (PL_regkind[OP(scan)]) { + case WHILEM: /* End of (?:...)* . */ + scan = NEXTOPER(scan); + goto finish; + case PLUS: + if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) { + next = NEXTOPER(scan); + if ( ( PL_regkind[OP(next)] == EXACT && ! isEXACTFish(OP(next))) || (flags & SCF_DO_STCLASS)) { - mincount = 1; - maxcount = REG_INFTY; - next = regnext(scan); - scan = NEXTOPER(scan); - goto do_curly; - } - } - if (flags & SCF_DO_SUBSTR) - data->pos_min++; + mincount = 1; + maxcount = REG_INFTY; + next = regnext(scan); + scan = NEXTOPER(scan); + goto do_curly; + } + } + if (flags & SCF_DO_SUBSTR) + data->pos_min++; /* This will bypass the formal 'min += minnext * mincount' * calculation in the do_curly path, so assumes min width * of the PLUS payload is exactly one. */ - min++; - /* FALLTHROUGH */ - case STAR: + min++; + /* FALLTHROUGH */ + case STAR: next = NEXTOPER(scan); /* This temporary node can now be turned into EXACTFU, and @@ -5483,121 +5483,121 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, FLAGS(next) = mask; } - if (flags & SCF_DO_STCLASS) { - mincount = 0; - maxcount = REG_INFTY; - next = regnext(scan); - scan = NEXTOPER(scan); - goto do_curly; - } - if (flags & SCF_DO_SUBSTR) { + if (flags & SCF_DO_STCLASS) { + mincount = 0; + maxcount = REG_INFTY; + next = regnext(scan); + scan = NEXTOPER(scan); + goto do_curly; + } + if (flags & SCF_DO_SUBSTR) { scan_commit(pRExC_state, data, minlenp, is_inf); /* Cannot extend fixed substrings */ - data->cur_is_floating = 1; /* float */ - } + data->cur_is_floating = 1; /* float */ + } is_inf = is_inf_internal = 1; scan = regnext(scan); - goto optimize_curly_tail; - case CURLY: - if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM) - && (scan->flags == stopparen)) - { - mincount = 1; - maxcount = 1; - } else { - mincount = ARG1(scan); - maxcount = ARG2(scan); - } - next = regnext(scan); - if (OP(scan) == CURLYX) { - I32 lp = (data ? *(data->last_closep) : 0); - scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX); - } - scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS; - next_is_eval = (OP(scan) == EVAL); - do_curly: - if (flags & SCF_DO_SUBSTR) { + goto optimize_curly_tail; + case CURLY: + if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM) + && (scan->flags == stopparen)) + { + mincount = 1; + maxcount = 1; + } else { + mincount = ARG1(scan); + maxcount = ARG2(scan); + } + next = regnext(scan); + if (OP(scan) == CURLYX) { + I32 lp = (data ? *(data->last_closep) : 0); + scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX); + } + scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS; + next_is_eval = (OP(scan) == EVAL); + do_curly: + if (flags & SCF_DO_SUBSTR) { if (mincount == 0) scan_commit(pRExC_state, data, minlenp, is_inf); /* Cannot extend fixed substrings */ - pos_before = data->pos_min; - } - if (data) { - fl = data->flags; - data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL); - if (is_inf) - data->flags |= SF_IS_INF; - } - if (flags & SCF_DO_STCLASS) { - ssc_init(pRExC_state, &this_class); - oclass = data->start_class; - data->start_class = &this_class; - f |= SCF_DO_STCLASS_AND; - f &= ~SCF_DO_STCLASS_OR; - } - /* Exclude from super-linear cache processing any {n,m} - regops for which the combination of input pos and regex - pos is not enough information to determine if a match - will be possible. - - For example, in the regex /foo(bar\s*){4,8}baz/ with the - regex pos at the \s*, the prospects for a match depend not - only on the input position but also on how many (bar\s*) - repeats into the {4,8} we are. */ + pos_before = data->pos_min; + } + if (data) { + fl = data->flags; + data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL); + if (is_inf) + data->flags |= SF_IS_INF; + } + if (flags & SCF_DO_STCLASS) { + ssc_init(pRExC_state, &this_class); + oclass = data->start_class; + data->start_class = &this_class; + f |= SCF_DO_STCLASS_AND; + f &= ~SCF_DO_STCLASS_OR; + } + /* Exclude from super-linear cache processing any {n,m} + regops for which the combination of input pos and regex + pos is not enough information to determine if a match + will be possible. + + For example, in the regex /foo(bar\s*){4,8}baz/ with the + regex pos at the \s*, the prospects for a match depend not + only on the input position but also on how many (bar\s*) + repeats into the {4,8} we are. */ if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY)) - f &= ~SCF_WHILEM_VISITED_POS; + f &= ~SCF_WHILEM_VISITED_POS; - /* This will finish on WHILEM, setting scan, or on NULL: */ + /* This will finish on WHILEM, setting scan, or on NULL: */ /* recurse study_chunk() on loop bodies */ - minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, + minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, last, data, stopparen, recursed_depth, NULL, (mincount == 0 ? (f & ~SCF_DO_SUBSTR) : f) , depth+1, mutate_ok); - if (flags & SCF_DO_STCLASS) - data->start_class = oclass; - if (mincount == 0 || minnext == 0) { - if (flags & SCF_DO_STCLASS_OR) { - ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class); - } - else if (flags & SCF_DO_STCLASS_AND) { - /* Switch to OR mode: cache the old value of - * data->start_class */ - INIT_AND_WITHP; - StructCopy(data->start_class, and_withp, regnode_ssc); - flags &= ~SCF_DO_STCLASS_AND; - StructCopy(&this_class, data->start_class, regnode_ssc); - flags |= SCF_DO_STCLASS_OR; + if (flags & SCF_DO_STCLASS) + data->start_class = oclass; + if (mincount == 0 || minnext == 0) { + if (flags & SCF_DO_STCLASS_OR) { + ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class); + } + else if (flags & SCF_DO_STCLASS_AND) { + /* Switch to OR mode: cache the old value of + * data->start_class */ + INIT_AND_WITHP; + StructCopy(data->start_class, and_withp, regnode_ssc); + flags &= ~SCF_DO_STCLASS_AND; + StructCopy(&this_class, data->start_class, regnode_ssc); + flags |= SCF_DO_STCLASS_OR; ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING; - } - } else { /* Non-zero len */ - if (flags & SCF_DO_STCLASS_OR) { - ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class); - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); - } - else if (flags & SCF_DO_STCLASS_AND) - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class); - flags &= ~SCF_DO_STCLASS; - } - if (!scan) /* It was not CURLYX, but CURLY. */ - scan = next; - if (((flags & (SCF_TRIE_DOING_RESTUDY|SCF_DO_SUBSTR))==SCF_DO_SUBSTR) - /* ? quantifier ok, except for (?{ ... }) */ - && (next_is_eval || !(mincount == 0 && maxcount == 1)) - && (minnext == 0) && (deltanext == 0) - && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR)) + } + } else { /* Non-zero len */ + if (flags & SCF_DO_STCLASS_OR) { + ssc_or(pRExC_state, data->start_class, (regnode_charclass *) &this_class); + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + } + else if (flags & SCF_DO_STCLASS_AND) + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &this_class); + flags &= ~SCF_DO_STCLASS; + } + if (!scan) /* It was not CURLYX, but CURLY. */ + scan = next; + if (((flags & (SCF_TRIE_DOING_RESTUDY|SCF_DO_SUBSTR))==SCF_DO_SUBSTR) + /* ? quantifier ok, except for (?{ ... }) */ + && (next_is_eval || !(mincount == 0 && maxcount == 1)) + && (minnext == 0) && (deltanext == 0) + && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR)) && maxcount <= REG_INFTY/3) /* Complement check for big count */ - { - _WARN_HELPER(RExC_precomp_end, packWARN(WARN_REGEXP), + { + _WARN_HELPER(RExC_precomp_end, packWARN(WARN_REGEXP), Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Quantifier unexpected on zero-length expression " "in regex m/%" UTF8f "/", - UTF8fARG(UTF, RExC_precomp_end - RExC_precomp, - RExC_precomp))); + UTF8fARG(UTF, RExC_precomp_end - RExC_precomp, + RExC_precomp))); } if ( ( minnext > 0 && mincount >= SSize_t_MAX / minnext ) @@ -5606,146 +5606,146 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, FAIL("Regexp out of space"); } - min += minnext * mincount; - is_inf_internal |= deltanext == OPTIMIZE_INFTY + min += minnext * mincount; + is_inf_internal |= deltanext == OPTIMIZE_INFTY || (maxcount == REG_INFTY && minnext + deltanext > 0); - is_inf |= is_inf_internal; + is_inf |= is_inf_internal; if (is_inf) { - delta = OPTIMIZE_INFTY; + delta = OPTIMIZE_INFTY; } else { - delta += (minnext + deltanext) * maxcount + delta += (minnext + deltanext) * maxcount - minnext * mincount; } - /* Try powerful optimization CURLYX => CURLYN. */ - if ( OP(oscan) == CURLYX && data - && data->flags & SF_IN_PAR - && !(data->flags & SF_HAS_EVAL) - && !deltanext && minnext == 1 + /* Try powerful optimization CURLYX => CURLYN. */ + if ( OP(oscan) == CURLYX && data + && data->flags & SF_IN_PAR + && !(data->flags & SF_HAS_EVAL) + && !deltanext && minnext == 1 && mutate_ok ) { - /* Try to optimize to CURLYN. */ - regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; - regnode * const nxt1 = nxt; + /* Try to optimize to CURLYN. */ + regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; + regnode * const nxt1 = nxt; #ifdef DEBUGGING - regnode *nxt2; + regnode *nxt2; #endif - /* Skip open. */ - nxt = regnext(nxt); - if (!REGNODE_SIMPLE(OP(nxt)) - && !(PL_regkind[OP(nxt)] == EXACT - && STR_LEN(nxt) == 1)) - goto nogo; + /* Skip open. */ + nxt = regnext(nxt); + if (!REGNODE_SIMPLE(OP(nxt)) + && !(PL_regkind[OP(nxt)] == EXACT + && STR_LEN(nxt) == 1)) + goto nogo; #ifdef DEBUGGING - nxt2 = nxt; + nxt2 = nxt; #endif - nxt = regnext(nxt); - if (OP(nxt) != CLOSE) - goto nogo; - if (RExC_open_parens) { + nxt = regnext(nxt); + if (OP(nxt) != CLOSE) + goto nogo; + if (RExC_open_parens) { /*open->CURLYM*/ RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan); /*close->while*/ RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt) + 2; - } - /* Now we know that nxt2 is the only contents: */ - oscan->flags = (U8)ARG(nxt); - OP(oscan) = CURLYN; - OP(nxt1) = NOTHING; /* was OPEN. */ + } + /* Now we know that nxt2 is the only contents: */ + oscan->flags = (U8)ARG(nxt); + OP(oscan) = CURLYN; + OP(nxt1) = NOTHING; /* was OPEN. */ #ifdef DEBUGGING - OP(nxt1 + 1) = OPTIMIZED; /* was count. */ - NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */ - NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */ - OP(nxt) = OPTIMIZED; /* was CLOSE. */ - OP(nxt + 1) = OPTIMIZED; /* was count. */ - NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */ + OP(nxt1 + 1) = OPTIMIZED; /* was count. */ + NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */ + NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */ + OP(nxt) = OPTIMIZED; /* was CLOSE. */ + OP(nxt + 1) = OPTIMIZED; /* was count. */ + NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */ #endif - } - nogo: - - /* Try optimization CURLYX => CURLYM. */ - if ( OP(oscan) == CURLYX && data - && !(data->flags & SF_HAS_PAR) - && !(data->flags & SF_HAS_EVAL) - && !deltanext /* atom is fixed width */ - && minnext != 0 /* CURLYM can't handle zero width */ + } + nogo: + + /* Try optimization CURLYX => CURLYM. */ + if ( OP(oscan) == CURLYX && data + && !(data->flags & SF_HAS_PAR) + && !(data->flags & SF_HAS_EVAL) + && !deltanext /* atom is fixed width */ + && minnext != 0 /* CURLYM can't handle zero width */ /* Nor characters whose fold at run-time may be * multi-character */ && ! (RExC_seen & REG_UNFOLDED_MULTI_SEEN) && mutate_ok - ) { - /* XXXX How to optimize if data == 0? */ - /* Optimize to a simpler form. */ - regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */ - regnode *nxt2; - - OP(oscan) = CURLYM; - while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/ - && (OP(nxt2) != WHILEM)) - nxt = nxt2; - OP(nxt2) = SUCCEED; /* Whas WHILEM */ - /* Need to optimize away parenths. */ - if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) { - /* Set the parenth number. */ - regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/ - - oscan->flags = (U8)ARG(nxt); - if (RExC_open_parens) { + ) { + /* XXXX How to optimize if data == 0? */ + /* Optimize to a simpler form. */ + regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */ + regnode *nxt2; + + OP(oscan) = CURLYM; + while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/ + && (OP(nxt2) != WHILEM)) + nxt = nxt2; + OP(nxt2) = SUCCEED; /* Whas WHILEM */ + /* Need to optimize away parenths. */ + if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) { + /* Set the parenth number. */ + regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/ + + oscan->flags = (U8)ARG(nxt); + if (RExC_open_parens) { /*open->CURLYM*/ RExC_open_parens[ARG(nxt1)] = REGNODE_OFFSET(oscan); /*close->NOTHING*/ RExC_close_parens[ARG(nxt1)] = REGNODE_OFFSET(nxt2) + 1; - } - OP(nxt1) = OPTIMIZED; /* was OPEN. */ - OP(nxt) = OPTIMIZED; /* was CLOSE. */ + } + OP(nxt1) = OPTIMIZED; /* was OPEN. */ + OP(nxt) = OPTIMIZED; /* was CLOSE. */ #ifdef DEBUGGING - OP(nxt1 + 1) = OPTIMIZED; /* was count. */ - OP(nxt + 1) = OPTIMIZED; /* was count. */ - NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */ - NEXT_OFF(nxt + 1) = 0; /* just for consistency. */ + OP(nxt1 + 1) = OPTIMIZED; /* was count. */ + OP(nxt + 1) = OPTIMIZED; /* was count. */ + NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */ + NEXT_OFF(nxt + 1) = 0; /* just for consistency. */ #endif #if 0 - while ( nxt1 && (OP(nxt1) != WHILEM)) { - regnode *nnxt = regnext(nxt1); - if (nnxt == nxt) { - if (reg_off_by_arg[OP(nxt1)]) - ARG_SET(nxt1, nxt2 - nxt1); - else if (nxt2 - nxt1 < U16_MAX) - NEXT_OFF(nxt1) = nxt2 - nxt1; - else - OP(nxt) = NOTHING; /* Cannot beautify */ - } - nxt1 = nnxt; - } + while ( nxt1 && (OP(nxt1) != WHILEM)) { + regnode *nnxt = regnext(nxt1); + if (nnxt == nxt) { + if (reg_off_by_arg[OP(nxt1)]) + ARG_SET(nxt1, nxt2 - nxt1); + else if (nxt2 - nxt1 < U16_MAX) + NEXT_OFF(nxt1) = nxt2 - nxt1; + else + OP(nxt) = NOTHING; /* Cannot beautify */ + } + nxt1 = nnxt; + } #endif - /* Optimize again: */ + /* Optimize again: */ /* recurse study_chunk() on optimised CURLYX => CURLYM */ - study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt, + study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt, NULL, stopparen, recursed_depth, NULL, 0, depth+1, mutate_ok); - } - else - oscan->flags = 0; - } - else if ((OP(oscan) == CURLYX) - && (flags & SCF_WHILEM_VISITED_POS) - /* See the comment on a similar expression above. - However, this time it's not a subexpression - we care about, but the expression itself. */ - && (maxcount == REG_INFTY) - && data) { - /* This stays as CURLYX, we can put the count/of pair. */ - /* Find WHILEM (as in regexec.c) */ - regnode *nxt = oscan + NEXT_OFF(oscan); - - if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */ - nxt += ARG(nxt); + } + else + oscan->flags = 0; + } + else if ((OP(oscan) == CURLYX) + && (flags & SCF_WHILEM_VISITED_POS) + /* See the comment on a similar expression above. + However, this time it's not a subexpression + we care about, but the expression itself. */ + && (maxcount == REG_INFTY) + && data) { + /* This stays as CURLYX, we can put the count/of pair. */ + /* Find WHILEM (as in regexec.c) */ + regnode *nxt = oscan + NEXT_OFF(oscan); + + if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */ + nxt += ARG(nxt); nxt = PREVOPER(nxt); if (nxt->flags & 0xf) { /* we've already set whilem count on this node */ @@ -5754,68 +5754,68 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, nxt->flags = (U8)(data->whilem_c | (RExC_whilem_seen << 4)); /* On WHILEM */ } - } - if (data && fl & (SF_HAS_PAR|SF_IN_PAR)) - pars++; - if (flags & SCF_DO_SUBSTR) { - SV *last_str = NULL; + } + if (data && fl & (SF_HAS_PAR|SF_IN_PAR)) + pars++; + if (flags & SCF_DO_SUBSTR) { + SV *last_str = NULL; STRLEN last_chrs = 0; - int counted = mincount != 0; + int counted = mincount != 0; if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */ - SSize_t b = pos_before >= data->last_start_min - ? pos_before : data->last_start_min; - STRLEN l; - const char * const s = SvPV_const(data->last_found, l); - SSize_t old = b - data->last_start_min; + SSize_t b = pos_before >= data->last_start_min + ? pos_before : data->last_start_min; + STRLEN l; + const char * const s = SvPV_const(data->last_found, l); + SSize_t old = b - data->last_start_min; assert(old >= 0); - if (UTF) - old = utf8_hop_forward((U8*)s, old, + if (UTF) + old = utf8_hop_forward((U8*)s, old, (U8 *) SvEND(data->last_found)) - (U8*)s; - l -= old; - /* Get the added string: */ - last_str = newSVpvn_utf8(s + old, l, UTF); + l -= old; + /* Get the added string: */ + last_str = newSVpvn_utf8(s + old, l, UTF); last_chrs = UTF ? utf8_length((U8*)(s + old), (U8*)(s + old + l)) : l; - if (deltanext == 0 && pos_before == b) { - /* What was added is a constant string */ - if (mincount > 1) { + if (deltanext == 0 && pos_before == b) { + /* What was added is a constant string */ + if (mincount > 1) { - SvGROW(last_str, (mincount * l) + 1); - repeatcpy(SvPVX(last_str) + l, - SvPVX_const(last_str), l, + SvGROW(last_str, (mincount * l) + 1); + repeatcpy(SvPVX(last_str) + l, + SvPVX_const(last_str), l, mincount - 1); - SvCUR_set(last_str, SvCUR(last_str) * mincount); - /* Add additional parts. */ - SvCUR_set(data->last_found, - SvCUR(data->last_found) - l); - sv_catsv(data->last_found, last_str); - { - SV * sv = data->last_found; - MAGIC *mg = - SvUTF8(sv) && SvMAGICAL(sv) ? - mg_find(sv, PERL_MAGIC_utf8) : NULL; - if (mg && mg->mg_len >= 0) - mg->mg_len += last_chrs * (mincount-1); - } + SvCUR_set(last_str, SvCUR(last_str) * mincount); + /* Add additional parts. */ + SvCUR_set(data->last_found, + SvCUR(data->last_found) - l); + sv_catsv(data->last_found, last_str); + { + SV * sv = data->last_found; + MAGIC *mg = + SvUTF8(sv) && SvMAGICAL(sv) ? + mg_find(sv, PERL_MAGIC_utf8) : NULL; + if (mg && mg->mg_len >= 0) + mg->mg_len += last_chrs * (mincount-1); + } last_chrs *= mincount; - data->last_end += l * (mincount - 1); - } - } else { - /* start offset must point into the last copy */ - data->last_start_min += minnext * (mincount - 1); - data->last_start_max = + data->last_end += l * (mincount - 1); + } + } else { + /* start offset must point into the last copy */ + data->last_start_min += minnext * (mincount - 1); + data->last_start_max = is_inf ? OPTIMIZE_INFTY - : data->last_start_max + + : data->last_start_max + (maxcount - 1) * (minnext + data->pos_delta); - } - } - /* It is counted once already... */ - data->pos_min += minnext * (mincount - counted); + } + } + /* It is counted once already... */ + data->pos_min += minnext * (mincount - counted); #if 0 Perl_re_printf( aTHX_ "counted=%" UVuf " deltanext=%" UVuf " OPTIMIZE_INFTY=%" UVuf " minnext=%" UVuf @@ -5827,52 +5827,52 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", (UV)(-counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount), (UV)(OPTIMIZE_INFTY - data->pos_delta)); #endif - if (deltanext == OPTIMIZE_INFTY + if (deltanext == OPTIMIZE_INFTY || -counted * deltanext + (minnext + deltanext) * maxcount - minnext * mincount >= OPTIMIZE_INFTY - data->pos_delta) - data->pos_delta = OPTIMIZE_INFTY; - else - data->pos_delta += - counted * deltanext + - (minnext + deltanext) * maxcount - minnext * mincount; - if (mincount != maxcount) { - /* Cannot extend fixed substrings found inside - the group. */ + data->pos_delta = OPTIMIZE_INFTY; + else + data->pos_delta += - counted * deltanext + + (minnext + deltanext) * maxcount - minnext * mincount; + if (mincount != maxcount) { + /* Cannot extend fixed substrings found inside + the group. */ scan_commit(pRExC_state, data, minlenp, is_inf); - if (mincount && last_str) { - SV * const sv = data->last_found; - MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? - mg_find(sv, PERL_MAGIC_utf8) : NULL; - - if (mg) - mg->mg_len = -1; - sv_setsv(sv, last_str); - data->last_end = data->pos_min; - data->last_start_min = data->pos_min - last_chrs; - data->last_start_max = is_inf - ? OPTIMIZE_INFTY - : data->pos_min + data->pos_delta - last_chrs; - } - data->cur_is_floating = 1; /* float */ - } - SvREFCNT_dec(last_str); - } - if (data && (fl & SF_HAS_EVAL)) - data->flags |= SF_HAS_EVAL; - optimize_curly_tail: - rck_elide_nothing(oscan); - continue; - - default: + if (mincount && last_str) { + SV * const sv = data->last_found; + MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? + mg_find(sv, PERL_MAGIC_utf8) : NULL; + + if (mg) + mg->mg_len = -1; + sv_setsv(sv, last_str); + data->last_end = data->pos_min; + data->last_start_min = data->pos_min - last_chrs; + data->last_start_max = is_inf + ? OPTIMIZE_INFTY + : data->pos_min + data->pos_delta - last_chrs; + } + data->cur_is_floating = 1; /* float */ + } + SvREFCNT_dec(last_str); + } + if (data && (fl & SF_HAS_EVAL)) + data->flags |= SF_HAS_EVAL; + optimize_curly_tail: + rck_elide_nothing(oscan); + continue; + + default: Perl_croak(aTHX_ "panic: unexpected varying REx opcode %d", OP(scan)); case REF: case CLUMP: - if (flags & SCF_DO_SUBSTR) { + if (flags & SCF_DO_SUBSTR) { /* Cannot expect anything... */ scan_commit(pRExC_state, data, minlenp, is_inf); - data->cur_is_floating = 1; /* float */ - } - is_inf = is_inf_internal = 1; - if (flags & SCF_DO_STCLASS_OR) { + data->cur_is_floating = 1; /* float */ + } + is_inf = is_inf_internal = 1; + if (flags & SCF_DO_STCLASS_OR) { if (OP(scan) == CLUMP) { /* Actually is any start char, but very few code points * aren't start characters */ @@ -5882,13 +5882,13 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", ssc_anything(data->start_class); } } - flags &= ~SCF_DO_STCLASS; - break; - } - } - else if (OP(scan) == LNBREAK) { - if (flags & SCF_DO_STCLASS) { - if (flags & SCF_DO_STCLASS_AND) { + flags &= ~SCF_DO_STCLASS; + break; + } + } + else if (OP(scan) == LNBREAK) { + if (flags & SCF_DO_STCLASS) { + if (flags & SCF_DO_STCLASS_AND) { ssc_intersection(data->start_class, PL_XPosix_ptrs[_CC_VERTSPACE], FALSE); ssc_clear_locale(data->start_class); @@ -5899,36 +5899,36 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", ssc_union(data->start_class, PL_XPosix_ptrs[_CC_VERTSPACE], FALSE); - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); /* See commit msg for * 749e076fceedeb708a624933726e7989f2302f6a */ ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; } - flags &= ~SCF_DO_STCLASS; + flags &= ~SCF_DO_STCLASS; } - min++; + min++; if (delta != OPTIMIZE_INFTY) delta++; /* Because of the 2 char string cr-lf */ if (flags & SCF_DO_SUBSTR) { /* Cannot expect anything... */ scan_commit(pRExC_state, data, minlenp, is_inf); - data->pos_min += 1; + data->pos_min += 1; if (data->pos_delta != OPTIMIZE_INFTY) { data->pos_delta += 1; } - data->cur_is_floating = 1; /* float */ - } - } - else if (REGNODE_SIMPLE(OP(scan))) { + data->cur_is_floating = 1; /* float */ + } + } + else if (REGNODE_SIMPLE(OP(scan))) { - if (flags & SCF_DO_SUBSTR) { + if (flags & SCF_DO_SUBSTR) { scan_commit(pRExC_state, data, minlenp, is_inf); - data->pos_min++; - } - min++; - if (flags & SCF_DO_STCLASS) { + data->pos_min++; + } + min++; + if (flags & SCF_DO_STCLASS) { bool invert = 0; SV* my_invlist = NULL; U8 namedclass; @@ -5936,21 +5936,21 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; - /* Some of the logic below assumes that switching - locale on will only add false positives. */ - switch (OP(scan)) { + /* Some of the logic below assumes that switching + locale on will only add false positives. */ + switch (OP(scan)) { - default: + default: #ifdef DEBUGGING Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); #endif - case SANY: - if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ - ssc_match_all_cp(data->start_class); - break; + case SANY: + if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ + ssc_match_all_cp(data->start_class); + break; - case REG_ANY: + case REG_ANY: { SV* REG_ANY_invlist = _new_invlist(2); REG_ANY_invlist = add_cp_to_invlist(REG_ANY_invlist, @@ -5970,8 +5970,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", ssc_clear_locale(data->start_class); } SvREFCNT_dec_NN(REG_ANY_invlist); - } - break; + } + break; case ANYOFD: case ANYOFL: @@ -5981,13 +5981,13 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", case ANYOFHr: case ANYOFHs: case ANYOF: - if (flags & SCF_DO_STCLASS_AND) - ssc_and(pRExC_state, data->start_class, + if (flags & SCF_DO_STCLASS_AND) + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) scan); - else - ssc_or(pRExC_state, data->start_class, + else + ssc_or(pRExC_state, data->start_class, (regnode_charclass *) scan); - break; + break; case NANYOFM: /* NANYOFM already contains the inversion of the input ANYOF data, so, unlike things like @@ -6028,11 +6028,11 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", break; } - case NPOSIXL: + case NPOSIXL: invert = 1; /* FALLTHROUGH */ - case POSIXL: + case POSIXL: namedclass = classnum_to_namedclass(FLAGS(scan)) + invert; if (flags & SCF_DO_STCLASS_AND) { bool was_there = cBOOL( @@ -6072,16 +6072,16 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", what's matched */ invert = 1; /* FALLTHROUGH */ - case POSIXA: + case POSIXA: my_invlist = invlist_clone(PL_Posix_ptrs[FLAGS(scan)], NULL); goto join_posix_and_ascii; - case NPOSIXD: - case NPOSIXU: + case NPOSIXD: + case NPOSIXU: invert = 1; /* FALLTHROUGH */ - case POSIXD: - case POSIXU: + case POSIXD: + case POSIXU: my_invlist = invlist_clone(PL_XPosix_ptrs[FLAGS(scan)], NULL); /* NPOSIXD matches all upper Latin1 code points unless the @@ -6105,23 +6105,23 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", ssc_union(data->start_class, my_invlist, invert); } SvREFCNT_dec(my_invlist); - } - if (flags & SCF_DO_STCLASS_OR) - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); - flags &= ~SCF_DO_STCLASS; - } - } - else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) { - data->flags |= (OP(scan) == MEOL - ? SF_BEFORE_MEOL - : SF_BEFORE_SEOL); + } + if (flags & SCF_DO_STCLASS_OR) + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + flags &= ~SCF_DO_STCLASS; + } + } + else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) { + data->flags |= (OP(scan) == MEOL + ? SF_BEFORE_MEOL + : SF_BEFORE_SEOL); scan_commit(pRExC_state, data, minlenp, is_inf); - } - else if ( PL_regkind[OP(scan)] == BRANCHJ - /* Lookbehind, or need to calculate parens/evals/stclass: */ - && (scan->flags || data || (flags & SCF_DO_STCLASS)) - && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) + } + else if ( PL_regkind[OP(scan)] == BRANCHJ + /* Lookbehind, or need to calculate parens/evals/stclass: */ + && (scan->flags || data || (flags & SCF_DO_STCLASS)) + && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) { if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY || OP(scan) == UNLESSM ) @@ -6139,16 +6139,16 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", if (data) { data_fake.whilem_c = data->whilem_c; data_fake.last_closep = data->last_closep; - } + } else data_fake.last_closep = &fake; - data_fake.pos_delta = delta; + data_fake.pos_delta = delta; if ( flags & SCF_DO_STCLASS && !scan->flags && OP(scan) == IFMATCH ) { /* Lookahead */ ssc_init(pRExC_state, &intrnl); data_fake.start_class = &intrnl; f |= SCF_DO_STCLASS_AND; - } + } if (flags & SCF_WHILEM_VISITED_POS) f |= SCF_WHILEM_VISITED_POS; next = regnext(scan); @@ -6165,7 +6165,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", || minnext > (I32)U8_MAX || minnext + deltanext > (I32)U8_MAX) { - FAIL2("Lookbehind longer than %" UVuf " not implemented", + FAIL2("Lookbehind longer than %" UVuf " not implemented", (UV)U8_MAX); } @@ -6190,24 +6190,24 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", data->whilem_c = data_fake.whilem_c; } if (f & SCF_DO_STCLASS_AND) { - if (flags & SCF_DO_STCLASS_OR) { - /* OR before, AND after: ideally we would recurse with - * data_fake to get the AND applied by study of the - * remainder of the pattern, and then derecurse; - * *** HACK *** for now just treat as "no information". - * See [perl #56690]. - */ - ssc_init(pRExC_state, data->start_class); - } else { + if (flags & SCF_DO_STCLASS_OR) { + /* OR before, AND after: ideally we would recurse with + * data_fake to get the AND applied by study of the + * remainder of the pattern, and then derecurse; + * *** HACK *** for now just treat as "no information". + * See [perl #56690]. + */ + ssc_init(pRExC_state, data->start_class); + } else { /* AND before and after: combine and continue. These * assertions are zero-length, so can match an EMPTY * string */ - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl); + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl); ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING; - } + } } - } + } #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY else { /* Positive Lookahead/lookbehind @@ -6245,9 +6245,9 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", data_fake.flags = 0; data_fake.substrs[0].flags = 0; data_fake.substrs[1].flags = 0; - data_fake.pos_delta = delta; + data_fake.pos_delta = delta; if (is_inf) - data_fake.flags |= SF_IS_INF; + data_fake.flags |= SF_IS_INF; if ( flags & SCF_DO_STCLASS && !scan->flags && OP(scan) == IFMATCH ) { /* Lookahead */ ssc_init(pRExC_state, &intrnl); @@ -6272,7 +6272,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", || *minnextp > (I32)U8_MAX || *minnextp + deltanext > (I32)U8_MAX) { - FAIL2("Lookbehind longer than %" UVuf " not implemented", + FAIL2("Lookbehind longer than %" UVuf " not implemented", (UV)U8_MAX); } @@ -6314,65 +6314,65 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", } } } - } + } #endif - } - else if (OP(scan) == OPEN) { - if (stopparen != (I32)ARG(scan)) - pars++; - } - else if (OP(scan) == CLOSE) { - if (stopparen == (I32)ARG(scan)) { - break; - } - if ((I32)ARG(scan) == is_par) { - next = regnext(scan); - - if ( next && (OP(next) != WHILEM) && next < last) - is_par = 0; /* Disable optimization */ - } - if (data) - *(data->last_closep) = ARG(scan); - } - else if (OP(scan) == EVAL) { - if (data) - data->flags |= SF_HAS_EVAL; - } - else if ( PL_regkind[OP(scan)] == ENDLIKE ) { - if (flags & SCF_DO_SUBSTR) { + } + else if (OP(scan) == OPEN) { + if (stopparen != (I32)ARG(scan)) + pars++; + } + else if (OP(scan) == CLOSE) { + if (stopparen == (I32)ARG(scan)) { + break; + } + if ((I32)ARG(scan) == is_par) { + next = regnext(scan); + + if ( next && (OP(next) != WHILEM) && next < last) + is_par = 0; /* Disable optimization */ + } + if (data) + *(data->last_closep) = ARG(scan); + } + else if (OP(scan) == EVAL) { + if (data) + data->flags |= SF_HAS_EVAL; + } + else if ( PL_regkind[OP(scan)] == ENDLIKE ) { + if (flags & SCF_DO_SUBSTR) { scan_commit(pRExC_state, data, minlenp, is_inf); - flags &= ~SCF_DO_SUBSTR; - } - if (data && OP(scan)==ACCEPT) { - data->flags |= SCF_SEEN_ACCEPT; - if (stopmin > min) - stopmin = min; - } - } - else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */ - { - if (flags & SCF_DO_SUBSTR) { + flags &= ~SCF_DO_SUBSTR; + } + if (data && OP(scan)==ACCEPT) { + data->flags |= SCF_SEEN_ACCEPT; + if (stopmin > min) + stopmin = min; + } + } + else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */ + { + if (flags & SCF_DO_SUBSTR) { scan_commit(pRExC_state, data, minlenp, is_inf); - data->cur_is_floating = 1; /* float */ - } - is_inf = is_inf_internal = 1; - if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ - ssc_anything(data->start_class); - flags &= ~SCF_DO_STCLASS; - } - else if (OP(scan) == GPOS) { + data->cur_is_floating = 1; /* float */ + } + is_inf = is_inf_internal = 1; + if (flags & SCF_DO_STCLASS_OR) /* Allow everything */ + ssc_anything(data->start_class); + flags &= ~SCF_DO_STCLASS; + } + else if (OP(scan) == GPOS) { if (!(RExC_rx->intflags & PREGf_GPOS_FLOAT) && - !(delta || is_inf || (data && data->pos_delta))) - { + !(delta || is_inf || (data && data->pos_delta))) + { if (!(RExC_rx->intflags & PREGf_ANCH) && (flags & SCF_DO_SUBSTR)) RExC_rx->intflags |= PREGf_ANCH_GPOS; - if (RExC_rx->gofs < (STRLEN)min) - RExC_rx->gofs = min; + if (RExC_rx->gofs < (STRLEN)min) + RExC_rx->gofs = min; } else { RExC_rx->intflags |= PREGf_GPOS_FLOAT; RExC_rx->gofs = 0; } - } + } #ifdef TRIE_STUDY_OPT #ifdef FULL_TRIE_STUDY else if (PL_regkind[OP(scan)] == TRIE) { @@ -6411,7 +6411,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", } else data_fake.last_closep = &fake; - data_fake.pos_delta = delta; + data_fake.pos_delta = delta; if (flags & SCF_DO_STCLASS) { ssc_init(pRExC_state, &this_class); data_fake.start_class = &this_class; @@ -6448,11 +6448,11 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", pars++; if (data_fake.flags & SCF_SEEN_ACCEPT) { if ( stopmin > min + min1) - stopmin = min + min1; - flags &= ~SCF_DO_SUBSTR; - if (data) - data->flags |= SCF_SEEN_ACCEPT; - } + stopmin = min + min1; + flags &= ~SCF_DO_SUBSTR; + if (data) + data->flags |= SCF_SEEN_ACCEPT; + } if (data) { if (data_fake.flags & SF_HAS_EVAL) data->flags |= SF_HAS_EVAL; @@ -6490,7 +6490,7 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", else { /* Switch to OR mode: cache the old value of * data->start_class */ - INIT_AND_WITHP; + INIT_AND_WITHP; StructCopy(data->start_class, and_withp, regnode_ssc); flags &= ~SCF_DO_STCLASS_AND; StructCopy(&accum, data->start_class, regnode_ssc); @@ -6501,24 +6501,24 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", continue; } #else - else if (PL_regkind[OP(scan)] == TRIE) { - reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ]; - U8*bang=NULL; + else if (PL_regkind[OP(scan)] == TRIE) { + reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ]; + U8*bang=NULL; - min += trie->minlen; - delta += (trie->maxlen - trie->minlen); - flags &= ~SCF_DO_STCLASS; /* xxx */ + min += trie->minlen; + delta += (trie->maxlen - trie->minlen); + flags &= ~SCF_DO_STCLASS; /* xxx */ if (flags & SCF_DO_SUBSTR) { /* Cannot expect anything... */ scan_commit(pRExC_state, data, minlenp, is_inf); - data->pos_min += trie->minlen; - data->pos_delta += (trie->maxlen - trie->minlen); - if (trie->maxlen != trie->minlen) - data->cur_is_floating = 1; /* float */ - } - if (trie->jump) /* no more substrings -- for now /grr*/ + data->pos_min += trie->minlen; + data->pos_delta += (trie->maxlen - trie->minlen); + if (trie->maxlen != trie->minlen) + data->cur_is_floating = 1; /* float */ + } + if (trie->jump) /* no more substrings -- for now /grr*/ flags &= ~SCF_DO_SUBSTR; - } + } else if (OP(scan) == REGEX_SET) { Perl_croak(aTHX_ "panic: %s regnode should be resolved" " before optimization", reg_name[REGEX_SET]); @@ -6527,8 +6527,8 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", #endif /* old or new */ #endif /* TRIE_STUDY_OPT */ - /* Else: zero-length, ignore. */ - scan = regnext(scan); + /* Else: zero-length, ignore. */ + scan = regnext(scan); } finish: @@ -6557,19 +6557,19 @@ Perl_re_printf( aTHX_ "LHS=%" UVuf " RHS=%" UVuf "\n", *deltap = is_inf_internal ? OPTIMIZE_INFTY : delta; if (flags & SCF_DO_SUBSTR && is_inf) - data->pos_delta = OPTIMIZE_INFTY - data->pos_min; + data->pos_delta = OPTIMIZE_INFTY - data->pos_min; if (is_par > (I32)U8_MAX) - is_par = 0; + is_par = 0; if (is_par && pars==1 && data) { - data->flags |= SF_IN_PAR; - data->flags &= ~SF_HAS_PAR; + data->flags |= SF_IN_PAR; + data->flags &= ~SF_HAS_PAR; } else if (pars && data) { - data->flags |= SF_HAS_PAR; - data->flags &= ~SF_IN_PAR; + data->flags |= SF_HAS_PAR; + data->flags &= ~SF_IN_PAR; } if (flags & SCF_DO_STCLASS_OR) - ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); + ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); if (flags & SCF_TRIE_RESTUDY) data->flags |= SCF_TRIE_RESTUDY; @@ -6595,12 +6595,12 @@ S_add_data(RExC_state_t* const pRExC_state, const char* const s, const U32 n) PERL_ARGS_ASSERT_ADD_DATA; Renewc(RExC_rxi->data, - sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1), - char, struct reg_data); + sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1), + char, struct reg_data); if(count) - Renew(RExC_rxi->data->what, count + n, U8); + Renew(RExC_rxi->data->what, count + n, U8); else - Newx(RExC_rxi->data->what, n, U8); + Newx(RExC_rxi->data->what, n, U8); RExC_rxi->data->count = count + n; Copy(s, RExC_rxi->data->what + count, n, U8); return count; @@ -6614,22 +6614,22 @@ Perl_reginitcolors(pTHX) { const char * const s = PerlEnv_getenv("PERL_RE_COLORS"); if (s) { - char *t = savepv(s); - int i = 0; - PL_colors[0] = t; - while (++i < 6) { - t = strchr(t, '\t'); - if (t) { - *t = '\0'; - PL_colors[i] = ++t; - } - else - PL_colors[i] = t = (char *)""; - } + char *t = savepv(s); + int i = 0; + PL_colors[0] = t; + while (++i < 6) { + t = strchr(t, '\t'); + if (t) { + *t = '\0'; + PL_colors[i] = ++t; + } + else + PL_colors[i] = t = (char *)""; + } } else { - int i = 0; - while (i < 6) - PL_colors[i++] = (char *)""; + int i = 0; + while (i < 6) + PL_colors[i++] = (char *)""; } PL_colorset = 1; } @@ -6666,24 +6666,24 @@ regexp_engine const * Perl_current_re_engine(pTHX) { if (IN_PERL_COMPILETIME) { - HV * const table = GvHV(PL_hintgv); - SV **ptr; + HV * const table = GvHV(PL_hintgv); + SV **ptr; - if (!table || !(PL_hints & HINT_LOCALIZE_HH)) - return &PL_core_reg_engine; - ptr = hv_fetchs(table, "regcomp", FALSE); - if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr))) - return &PL_core_reg_engine; - return INT2PTR(regexp_engine*, SvIV(*ptr)); + if (!table || !(PL_hints & HINT_LOCALIZE_HH)) + return &PL_core_reg_engine; + ptr = hv_fetchs(table, "regcomp", FALSE); + if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr))) + return &PL_core_reg_engine; + return INT2PTR(regexp_engine*, SvIV(*ptr)); } else { - SV *ptr; - if (!PL_curcop->cop_hints_hash) - return &PL_core_reg_engine; - ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0); - if ( !(ptr && SvIOK(ptr) && SvIV(ptr))) - return &PL_core_reg_engine; - return INT2PTR(regexp_engine*, SvIV(ptr)); + SV *ptr; + if (!PL_curcop->cop_hints_hash) + return &PL_core_reg_engine; + ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0); + if ( !(ptr && SvIOK(ptr) && SvIV(ptr))) + return &PL_core_reg_engine; + return INT2PTR(regexp_engine*, SvIV(ptr)); } } @@ -6699,7 +6699,7 @@ Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags) /* Dispatch a request to compile a regexp to correct regexp engine. */ DEBUG_COMPILE_r({ Perl_re_printf( aTHX_ "Using engine %" UVxf "\n", - PTR2UV(eng)); + PTR2UV(eng)); }); return CALLREGCOMP_ENG(eng, pattern, flags); } @@ -6770,7 +6770,7 @@ S_alloc_code_blocks(pTHX_ int ncode) static void S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state, - char **pat_p, STRLEN *plen_p, int num_code_blocks) + char **pat_p, STRLEN *plen_p, int num_code_blocks) { U8 *const src = (U8*)*pat_p; U8 *dst, *d; @@ -6929,7 +6929,7 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, oplist = OpSIBLING(oplist);; } - /* apply magic and QR overloading to arg */ + /* apply magic and QR overloading to arg */ SvGETMAGIC(msv); if (SvROK(msv) && SvAMAGIC(msv)) { @@ -7061,7 +7061,7 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, static bool S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state, - char *pat, STRLEN plen) + char *pat, STRLEN plen) { int n = 0; STRLEN s; @@ -7069,21 +7069,21 @@ S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state, PERL_UNUSED_CONTEXT; for (s = 0; s < plen; s++) { - if ( pRExC_state->code_blocks + if ( pRExC_state->code_blocks && n < pRExC_state->code_blocks->count - && s == pRExC_state->code_blocks->cb[n].start) - { - s = pRExC_state->code_blocks->cb[n].end; - n++; - continue; - } - /* TODO ideally should handle [..], (#..), /#.../x to reduce false - * positives here */ - if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' && - (pat[s+2] == '{' + && s == pRExC_state->code_blocks->cb[n].start) + { + s = pRExC_state->code_blocks->cb[n].end; + n++; + continue; + } + /* TODO ideally should handle [..], (#..), /#.../x to reduce false + * positives here */ + if (pat[s] == '(' && s+2 <= plen && pat[s+1] == '?' && + (pat[s+2] == '{' || (s + 2 <= plen && pat[s+2] == '?' && pat[s+3] == '{')) - ) - return 1; + ) + return 1; } return 0; } @@ -7120,39 +7120,39 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, DECLARE_AND_GET_RE_DEBUG_FLAGS; if (pRExC_state->runtime_code_qr) { - /* this is the second time we've been called; this should - * only happen if the main pattern got upgraded to utf8 - * during compilation; re-use the qr we compiled first time - * round (which should be utf8 too) - */ - qr = pRExC_state->runtime_code_qr; - pRExC_state->runtime_code_qr = NULL; - assert(RExC_utf8 && SvUTF8(qr)); + /* this is the second time we've been called; this should + * only happen if the main pattern got upgraded to utf8 + * during compilation; re-use the qr we compiled first time + * round (which should be utf8 too) + */ + qr = pRExC_state->runtime_code_qr; + pRExC_state->runtime_code_qr = NULL; + assert(RExC_utf8 && SvUTF8(qr)); } else { - int n = 0; - STRLEN s; - char *p, *newpat; - int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */ - SV *sv, *qr_ref; - dSP; - - /* determine how many extra chars we need for ' and \ escaping */ - for (s = 0; s < plen; s++) { - if (pat[s] == '\'' || pat[s] == '\\') - newlen++; - } - - Newx(newpat, newlen, char); - p = newpat; - *p++ = 'q'; *p++ = 'r'; *p++ = '\''; - - for (s = 0; s < plen; s++) { - if ( pRExC_state->code_blocks - && n < pRExC_state->code_blocks->count - && s == pRExC_state->code_blocks->cb[n].start) - { - /* blank out literal code block so that they aren't + int n = 0; + STRLEN s; + char *p, *newpat; + int newlen = plen + 7; /* allow for "qr''xx\0" extra chars */ + SV *sv, *qr_ref; + dSP; + + /* determine how many extra chars we need for ' and \ escaping */ + for (s = 0; s < plen; s++) { + if (pat[s] == '\'' || pat[s] == '\\') + newlen++; + } + + Newx(newpat, newlen, char); + p = newpat; + *p++ = 'q'; *p++ = 'r'; *p++ = '\''; + + for (s = 0; s < plen; s++) { + if ( pRExC_state->code_blocks + && n < pRExC_state->code_blocks->count + && s == pRExC_state->code_blocks->cb[n].start) + { + /* blank out literal code block so that they aren't * recompiled: eg change from/to: * /(?{xyz})/ * /(?=====)/ @@ -7163,76 +7163,76 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, * /(?(?{xyz}))/ * /(?(?=====))/ */ - assert(pat[s] == '('); - assert(pat[s+1] == '?'); + assert(pat[s] == '('); + assert(pat[s+1] == '?'); *p++ = '('; *p++ = '?'; s += 2; - while (s < pRExC_state->code_blocks->cb[n].end) { - *p++ = '='; - s++; - } + while (s < pRExC_state->code_blocks->cb[n].end) { + *p++ = '='; + s++; + } *p++ = ')'; - n++; - continue; - } - if (pat[s] == '\'' || pat[s] == '\\') - *p++ = '\\'; - *p++ = pat[s]; - } - *p++ = '\''; - if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) { - *p++ = 'x'; + n++; + continue; + } + if (pat[s] == '\'' || pat[s] == '\\') + *p++ = '\\'; + *p++ = pat[s]; + } + *p++ = '\''; + if (pRExC_state->pm_flags & RXf_PMf_EXTENDED) { + *p++ = 'x'; if (pRExC_state->pm_flags & RXf_PMf_EXTENDED_MORE) { *p++ = 'x'; } } - *p++ = '\0'; - DEBUG_COMPILE_r({ + *p++ = '\0'; + DEBUG_COMPILE_r({ Perl_re_printf( aTHX_ - "%sre-parsing pattern for runtime code:%s %s\n", - PL_colors[4], PL_colors[5], newpat); - }); + "%sre-parsing pattern for runtime code:%s %s\n", + PL_colors[4], PL_colors[5], newpat); + }); - sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0); - Safefree(newpat); + sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0); + Safefree(newpat); - ENTER; - SAVETMPS; - save_re_context(); - PUSHSTACKi(PERLSI_REQUIRE); + ENTER; + SAVETMPS; + save_re_context(); + PUSHSTACKi(PERLSI_REQUIRE); /* G_RE_REPARSING causes the toker to collapse \\ into \ when * parsing qr''; normally only q'' does this. It also alters * hints handling */ - eval_sv(sv, G_SCALAR|G_RE_REPARSING); - SvREFCNT_dec_NN(sv); - SPAGAIN; - qr_ref = POPs; - PUTBACK; - { - SV * const errsv = ERRSV; - if (SvTRUE_NN(errsv)) + eval_sv(sv, G_SCALAR|G_RE_REPARSING); + SvREFCNT_dec_NN(sv); + SPAGAIN; + qr_ref = POPs; + PUTBACK; + { + SV * const errsv = ERRSV; + if (SvTRUE_NN(errsv)) /* use croak_sv ? */ - Perl_croak_nocontext("%" SVf, SVfARG(errsv)); - } - assert(SvROK(qr_ref)); - qr = SvRV(qr_ref); - assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp); - /* the leaving below frees the tmp qr_ref. - * Give qr a life of its own */ - SvREFCNT_inc(qr); - POPSTACK; - FREETMPS; - LEAVE; + Perl_croak_nocontext("%" SVf, SVfARG(errsv)); + } + assert(SvROK(qr_ref)); + qr = SvRV(qr_ref); + assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp); + /* the leaving below frees the tmp qr_ref. + * Give qr a life of its own */ + SvREFCNT_inc(qr); + POPSTACK; + FREETMPS; + LEAVE; } if (!RExC_utf8 && SvUTF8(qr)) { - /* first time through; the pattern got upgraded; save the - * qr for the next time through */ - assert(!pRExC_state->runtime_code_qr); - pRExC_state->runtime_code_qr = qr; - return 0; + /* first time through; the pattern got upgraded; save the + * qr for the next time through */ + assert(!pRExC_state->runtime_code_qr); + pRExC_state->runtime_code_qr = qr; + return 0; } @@ -7241,17 +7241,17 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, /* merge the main (r1) and run-time (r2) code blocks into one */ { - RXi_GET_DECL(ReANY((REGEXP *)qr), r2); - struct reg_code_block *new_block, *dst; - RExC_state_t * const r1 = pRExC_state; /* convenient alias */ - int i1 = 0, i2 = 0; + RXi_GET_DECL(ReANY((REGEXP *)qr), r2); + struct reg_code_block *new_block, *dst; + RExC_state_t * const r1 = pRExC_state; /* convenient alias */ + int i1 = 0, i2 = 0; int r1c, r2c; - if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */ - { - SvREFCNT_dec_NN(qr); - return 1; - } + if (!r2->code_blocks || !r2->code_blocks->count) /* we guessed wrong */ + { + SvREFCNT_dec_NN(qr); + return 1; + } if (!r1->code_blocks) r1->code_blocks = S_alloc_code_blocks(aTHX_ 0); @@ -7259,46 +7259,46 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, r1c = r1->code_blocks->count; r2c = r2->code_blocks->count; - Newx(new_block, r1c + r2c, struct reg_code_block); - - dst = new_block; - - while (i1 < r1c || i2 < r2c) { - struct reg_code_block *src; - bool is_qr = 0; - - if (i1 == r1c) { - src = &r2->code_blocks->cb[i2++]; - is_qr = 1; - } - else if (i2 == r2c) - src = &r1->code_blocks->cb[i1++]; - else if ( r1->code_blocks->cb[i1].start - < r2->code_blocks->cb[i2].start) - { - src = &r1->code_blocks->cb[i1++]; - assert(src->end < r2->code_blocks->cb[i2].start); - } - else { - assert( r1->code_blocks->cb[i1].start - > r2->code_blocks->cb[i2].start); - src = &r2->code_blocks->cb[i2++]; - is_qr = 1; - assert(src->end < r1->code_blocks->cb[i1].start); - } - - assert(pat[src->start] == '('); - assert(pat[src->end] == ')'); - dst->start = src->start; - dst->end = src->end; - dst->block = src->block; - dst->src_regex = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr) - : src->src_regex; - dst++; - } - r1->code_blocks->count += r2c; - Safefree(r1->code_blocks->cb); - r1->code_blocks->cb = new_block; + Newx(new_block, r1c + r2c, struct reg_code_block); + + dst = new_block; + + while (i1 < r1c || i2 < r2c) { + struct reg_code_block *src; + bool is_qr = 0; + + if (i1 == r1c) { + src = &r2->code_blocks->cb[i2++]; + is_qr = 1; + } + else if (i2 == r2c) + src = &r1->code_blocks->cb[i1++]; + else if ( r1->code_blocks->cb[i1].start + < r2->code_blocks->cb[i2].start) + { + src = &r1->code_blocks->cb[i1++]; + assert(src->end < r2->code_blocks->cb[i2].start); + } + else { + assert( r1->code_blocks->cb[i1].start + > r2->code_blocks->cb[i2].start); + src = &r2->code_blocks->cb[i2++]; + is_qr = 1; + assert(src->end < r1->code_blocks->cb[i1].start); + } + + assert(pat[src->start] == '('); + assert(pat[src->end] == ')'); + dst->start = src->start; + dst->end = src->end; + dst->block = src->block; + dst->src_regex = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr) + : src->src_regex; + dst++; + } + r1->code_blocks->count += r2c; + Safefree(r1->code_blocks->cb); + r1->code_blocks->cb = new_block; } SvREFCNT_dec_NN(qr); @@ -7506,8 +7506,8 @@ S_set_regex_pv(pTHX_ RExC_state_t *pRExC_state, REGEXP *Rx) REGEXP * Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, - OP *expr, const regexp_engine* eng, REGEXP *old_re, - bool *is_bare_re, const U32 orig_rx_flags, const U32 pm_flags) + OP *expr, const regexp_engine* eng, REGEXP *old_re, + bool *is_bare_re, const U32 orig_rx_flags, const U32 pm_flags) { REGEXP *Rx; /* Capital 'R' means points to a REGEXP */ STRLEN plen; @@ -7548,19 +7548,19 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, pRExC_state->code_blocks = NULL; if (is_bare_re) - *is_bare_re = FALSE; + *is_bare_re = FALSE; if (expr && (expr->op_type == OP_LIST || - (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) { - /* allocate code_blocks if needed */ - OP *o; - int ncode = 0; + (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) { + /* allocate code_blocks if needed */ + OP *o; + int ncode = 0; - for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) - if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) - ncode++; /* count of DO blocks */ + for (o = cLISTOPx(expr)->op_first; o; o = OpSIBLING(o)) + if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) + ncode++; /* count of DO blocks */ - if (ncode) + if (ncode) pRExC_state->code_blocks = S_alloc_code_blocks(aTHX_ ncode); } @@ -7638,15 +7638,15 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, exp = SvPV_nomg(pat, plen); if (!eng->op_comp) { - if ((SvUTF8(pat) && IN_BYTES) - || SvGMAGICAL(pat) || SvAMAGIC(pat)) - { - /* make a temporary copy; either to convert to bytes, - * or to avoid repeating get-magic / overloaded stringify */ - pat = newSVpvn_flags(exp, plen, SVs_TEMP | - (IN_BYTES ? 0 : SvUTF8(pat))); - } - return CALLREGCOMP_ENG(eng, pat, orig_rx_flags); + if ((SvUTF8(pat) && IN_BYTES) + || SvGMAGICAL(pat) || SvAMAGIC(pat)) + { + /* make a temporary copy; either to convert to bytes, + * or to avoid repeating get-magic / overloaded stringify */ + pat = newSVpvn_flags(exp, plen, SVs_TEMP | + (IN_BYTES ? 0 : SvUTF8(pat))); + } + return CALLREGCOMP_ENG(eng, pat, orig_rx_flags); } /* ignore the utf8ness if the pattern is 0 length */ @@ -7690,11 +7690,11 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, * to utf8 */ if ((pm_flags & PMf_USE_RE_EVAL) - /* this second condition covers the non-regex literal case, - * i.e. $foo =~ '(?{})'. */ - || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL)) + /* this second condition covers the non-regex literal case, + * i.e. $foo =~ '(?{})'. */ + || (IN_PERL_COMPILETIME && (PL_hints & HINT_RE_EVAL)) ) - runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen); + runtime_code = S_has_runtime_code(aTHX_ pRExC_state, exp, plen); redo_parse: /* return old regex if pattern hasn't changed */ @@ -7708,10 +7708,10 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, && !recompile && !!RX_UTF8(old_re) == !!RExC_utf8 && ( RX_COMPFLAGS(old_re) == ( orig_rx_flags & RXf_PMf_FLAGCOPYMASK ) ) - && RX_PRECOMP(old_re) - && RX_PRELEN(old_re) == plen + && RX_PRECOMP(old_re) + && RX_PRELEN(old_re) == plen && memEQ(RX_PRECOMP(old_re), exp, plen) - && !runtime_code /* with runtime code, always recompile */ ) + && !runtime_code /* with runtime code, always recompile */ ) { DEBUG_COMPILE_r({ SV *dsv= sv_newmortal(); @@ -7734,9 +7734,9 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, && initial_charset == REGEX_DEPENDS_CHARSET) { - /* Set to use unicode semantics if the pattern is in utf8 and has the - * 'depends' charset specified, as it means unicode when utf8 */ - set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET); + /* Set to use unicode semantics if the pattern is in utf8 and has the + * 'depends' charset specified, as it means unicode when utf8 */ + set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET); RExC_uni_semantics = 1; } @@ -7744,16 +7744,16 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (runtime_code) { assert(TAINTING_get || !TAINT_get); - if (TAINT_get) - Perl_croak(aTHX_ "Eval-group in insecure regular expression"); + if (TAINT_get) + Perl_croak(aTHX_ "Eval-group in insecure regular expression"); - if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) { - /* whoops, we have a non-utf8 pattern, whilst run-time code - * got compiled as utf8. Try again with a utf8 pattern */ + if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) { + /* whoops, we have a non-utf8 pattern, whilst run-time code + * got compiled as utf8. Try again with a utf8 pattern */ S_pat_upgrade_to_utf8(aTHX_ pRExC_state, &exp, &plen, pRExC_state->code_blocks ? pRExC_state->code_blocks->count : 0); goto redo_parse; - } + } } assert(!pRExC_state->runtime_code_qr); @@ -7828,7 +7828,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RXp_COMPFLAGS(RExC_rx) = orig_rx_flags & RXf_PMf_FLAGCOPYMASK; if (pm_flags & PMf_IS_QR) { - RExC_rxi->code_blocks = pRExC_state->code_blocks; + RExC_rxi->code_blocks = pRExC_state->code_blocks; if (RExC_rxi->code_blocks) { RExC_rxi->code_blocks->refcnt++; } @@ -7870,7 +7870,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_total_parens = RExC_npar; } else if (! MUST_RESTART(flags)) { - ReREFCNT_dec(Rx); + ReREFCNT_dec(Rx); Perl_croak(aTHX_ "panic: reg returned failure to re_op_compile, flags=%#" UVxf, (UV) flags); } @@ -8032,7 +8032,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN; else RExC_seen &= ~REG_TOP_LEVEL_BRANCHES_SEEN; - StructCopy(&zero_scan_data, &data, scan_data_t); + StructCopy(&zero_scan_data, &data, scan_data_t); } #else StructCopy(&zero_scan_data, &data, scan_data_t); @@ -8043,171 +8043,171 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */ if (UTF) - SvUTF8_on(Rx); /* Unicode in it? */ + SvUTF8_on(Rx); /* Unicode in it? */ RExC_rxi->regstclass = NULL; if (RExC_naughty >= TOO_NAUGHTY) /* Probably an expensive pattern. */ - RExC_rx->intflags |= PREGf_NAUGHTY; + RExC_rx->intflags |= PREGf_NAUGHTY; scan = RExC_rxi->program + 1; /* First BRANCH. */ /* testing for BRANCH here tells us whether there is "must appear" data in the pattern. If there is then we can use it for optimisations */ if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)) { /* Only one top-level choice. */ - SSize_t fake; - STRLEN longest_length[2]; - regnode_ssc ch_class; /* pointed to by data */ - int stclass_flag; - SSize_t last_close = 0; /* pointed to by data */ + SSize_t fake; + STRLEN longest_length[2]; + regnode_ssc ch_class; /* pointed to by data */ + int stclass_flag; + SSize_t last_close = 0; /* pointed to by data */ regnode *first= scan; regnode *first_next= regnext(first); int i; - /* - * Skip introductions and multiplicators >= 1 - * so that we can extract the 'meat' of the pattern that must - * match in the large if() sequence following. - * NOTE that EXACT is NOT covered here, as it is normally - * picked up by the optimiser separately. - * - * This is unfortunate as the optimiser isnt handling lookahead - * properly currently. - * - */ - while ((OP(first) == OPEN && (sawopen = 1)) || - /* An OR of *one* alternative - should not happen now. */ - (OP(first) == BRANCH && OP(first_next) != BRANCH) || - /* for now we can't handle lookbehind IFMATCH*/ - (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) || - (OP(first) == PLUS) || - (OP(first) == MINMOD) || - /* An {n,m} with n>0 */ - (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) || - (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END )) - { - /* - * the only op that could be a regnode is PLUS, all the rest - * will be regnode_1 or regnode_2. - * + /* + * Skip introductions and multiplicators >= 1 + * so that we can extract the 'meat' of the pattern that must + * match in the large if() sequence following. + * NOTE that EXACT is NOT covered here, as it is normally + * picked up by the optimiser separately. + * + * This is unfortunate as the optimiser isnt handling lookahead + * properly currently. + * + */ + while ((OP(first) == OPEN && (sawopen = 1)) || + /* An OR of *one* alternative - should not happen now. */ + (OP(first) == BRANCH && OP(first_next) != BRANCH) || + /* for now we can't handle lookbehind IFMATCH*/ + (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) || + (OP(first) == PLUS) || + (OP(first) == MINMOD) || + /* An {n,m} with n>0 */ + (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) || + (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END )) + { + /* + * the only op that could be a regnode is PLUS, all the rest + * will be regnode_1 or regnode_2. + * * (yves doesn't think this is true) - */ - if (OP(first) == PLUS) - sawplus = 1; + */ + if (OP(first) == PLUS) + sawplus = 1; else { if (OP(first) == MINMOD) sawminmod = 1; - first += regarglen[OP(first)]; + first += regarglen[OP(first)]; } - first = NEXTOPER(first); - first_next= regnext(first); - } + first = NEXTOPER(first); + first_next= regnext(first); + } - /* Starting-point info. */ + /* Starting-point info. */ again: DEBUG_PEEP("first:", first, 0, 0); /* Ignore EXACT as we deal with it later. */ - if (PL_regkind[OP(first)] == EXACT) { - if (! isEXACTFish(OP(first))) { - NOOP; /* Empty, get anchored substr later. */ + if (PL_regkind[OP(first)] == EXACT) { + if (! isEXACTFish(OP(first))) { + NOOP; /* Empty, get anchored substr later. */ } - else - RExC_rxi->regstclass = first; - } + else + RExC_rxi->regstclass = first; + } #ifdef TRIE_STCLASS - else if (PL_regkind[OP(first)] == TRIE && - ((reg_trie_data *)RExC_rxi->data->data[ ARG(first) ])->minlen>0) - { + else if (PL_regkind[OP(first)] == TRIE && + ((reg_trie_data *)RExC_rxi->data->data[ ARG(first) ])->minlen>0) + { /* this can happen only on restudy */ RExC_rxi->regstclass = construct_ahocorasick_from_trie(pRExC_state, (regnode *)first, 0); - } + } #endif - else if (REGNODE_SIMPLE(OP(first))) - RExC_rxi->regstclass = first; - else if (PL_regkind[OP(first)] == BOUND || - PL_regkind[OP(first)] == NBOUND) - RExC_rxi->regstclass = first; - else if (PL_regkind[OP(first)] == BOL) { + else if (REGNODE_SIMPLE(OP(first))) + RExC_rxi->regstclass = first; + else if (PL_regkind[OP(first)] == BOUND || + PL_regkind[OP(first)] == NBOUND) + RExC_rxi->regstclass = first; + else if (PL_regkind[OP(first)] == BOL) { RExC_rx->intflags |= (OP(first) == MBOL ? PREGf_ANCH_MBOL : PREGf_ANCH_SBOL); - first = NEXTOPER(first); - goto again; - } - else if (OP(first) == GPOS) { + first = NEXTOPER(first); + goto again; + } + else if (OP(first) == GPOS) { RExC_rx->intflags |= PREGf_ANCH_GPOS; - first = NEXTOPER(first); - goto again; - } - else if ((!sawopen || !RExC_sawback) && + first = NEXTOPER(first); + goto again; + } + else if ((!sawopen || !RExC_sawback) && !sawlookahead && - (OP(first) == STAR && - PL_regkind[OP(NEXTOPER(first))] == REG_ANY) && + (OP(first) == STAR && + PL_regkind[OP(NEXTOPER(first))] == REG_ANY) && !(RExC_rx->intflags & PREGf_ANCH) && !pRExC_state->code_blocks) - { - /* turn .* into ^.* with an implied $*=1 */ - const int type = - (OP(NEXTOPER(first)) == REG_ANY) + { + /* turn .* into ^.* with an implied $*=1 */ + const int type = + (OP(NEXTOPER(first)) == REG_ANY) ? PREGf_ANCH_MBOL : PREGf_ANCH_SBOL; RExC_rx->intflags |= (type | PREGf_IMPLICIT); - first = NEXTOPER(first); - goto again; - } + first = NEXTOPER(first); + goto again; + } if (sawplus && !sawminmod && !sawlookahead && (!sawopen || !RExC_sawback) - && !pRExC_state->code_blocks) /* May examine pos and $& */ - /* x+ must match at the 1st pos of run of x's */ - RExC_rx->intflags |= PREGf_SKIP; + && !pRExC_state->code_blocks) /* May examine pos and $& */ + /* x+ must match at the 1st pos of run of x's */ + RExC_rx->intflags |= PREGf_SKIP; - /* Scan is after the zeroth branch, first is atomic matcher. */ + /* Scan is after the zeroth branch, first is atomic matcher. */ #ifdef TRIE_STUDY_OPT - DEBUG_PARSE_r( - if (!restudied) + DEBUG_PARSE_r( + if (!restudied) Perl_re_printf( aTHX_ "first at %" IVdf "\n", - (IV)(first - scan + 1)) + (IV)(first - scan + 1)) ); #else - DEBUG_PARSE_r( + DEBUG_PARSE_r( Perl_re_printf( aTHX_ "first at %" IVdf "\n", - (IV)(first - scan + 1)) + (IV)(first - scan + 1)) ); #endif - /* - * If there's something expensive in the r.e., find the - * longest literal string that must appear and make it the - * regmust. Resolve ties in favor of later strings, since - * the regstart check works with the beginning of the r.e. - * and avoiding duplication strengthens checking. Not a - * strong reason, but sufficient in the absence of others. - * [Now we resolve ties in favor of the earlier string if - * it happens that c_offset_min has been invalidated, since the - * earlier string may buy us something the later one won't.] - */ - - data.substrs[0].str = newSVpvs(""); - data.substrs[1].str = newSVpvs(""); - data.last_found = newSVpvs(""); - data.cur_is_floating = 0; /* initially any found substring is fixed */ - ENTER_with_name("study_chunk"); - SAVEFREESV(data.substrs[0].str); - SAVEFREESV(data.substrs[1].str); - SAVEFREESV(data.last_found); - first = scan; - if (!RExC_rxi->regstclass) { - ssc_init(pRExC_state, &ch_class); - data.start_class = &ch_class; - stclass_flag = SCF_DO_STCLASS_AND; - } else /* XXXX Check for BOUND? */ - stclass_flag = 0; - data.last_closep = &last_close; + /* + * If there's something expensive in the r.e., find the + * longest literal string that must appear and make it the + * regmust. Resolve ties in favor of later strings, since + * the regstart check works with the beginning of the r.e. + * and avoiding duplication strengthens checking. Not a + * strong reason, but sufficient in the absence of others. + * [Now we resolve ties in favor of the earlier string if + * it happens that c_offset_min has been invalidated, since the + * earlier string may buy us something the later one won't.] + */ + + data.substrs[0].str = newSVpvs(""); + data.substrs[1].str = newSVpvs(""); + data.last_found = newSVpvs(""); + data.cur_is_floating = 0; /* initially any found substring is fixed */ + ENTER_with_name("study_chunk"); + SAVEFREESV(data.substrs[0].str); + SAVEFREESV(data.substrs[1].str); + SAVEFREESV(data.last_found); + first = scan; + if (!RExC_rxi->regstclass) { + ssc_init(pRExC_state, &ch_class); + data.start_class = &ch_class; + stclass_flag = SCF_DO_STCLASS_AND; + } else /* XXXX Check for BOUND? */ + stclass_flag = 0; + data.last_closep = &last_close; DEBUG_RExC_seen(); /* * MAIN ENTRY FOR study_chunk() FOR m/PATTERN/ * (NO top level branches) */ - minlen = study_chunk(pRExC_state, &first, &minlen, &fake, + minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */ &data, -1, 0, NULL, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag @@ -8218,15 +8218,15 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, CHECK_RESTUDY_GOTO_butfirst(LEAVE_with_name("study_chunk")); - if ( RExC_total_parens == 1 && !data.cur_is_floating - && data.last_start_min == 0 && data.last_end > 0 - && !RExC_seen_zerolen + if ( RExC_total_parens == 1 && !data.cur_is_floating + && data.last_start_min == 0 && data.last_end > 0 + && !RExC_seen_zerolen && !(RExC_seen & REG_VERBARG_SEEN) && !(RExC_seen & REG_GPOS_SEEN) ){ - RExC_rx->extflags |= RXf_CHECK_ALL; + RExC_rx->extflags |= RXf_CHECK_ALL; } - scan_commit(pRExC_state, &data,&minlen, 0); + scan_commit(pRExC_state, &data,&minlen, 0); /* XXX this is done in reverse order because that's the way the @@ -8263,39 +8263,39 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, } } - LEAVE_with_name("study_chunk"); + LEAVE_with_name("study_chunk"); - if (RExC_rxi->regstclass - && (OP(RExC_rxi->regstclass) == REG_ANY || OP(RExC_rxi->regstclass) == SANY)) - RExC_rxi->regstclass = NULL; + if (RExC_rxi->regstclass + && (OP(RExC_rxi->regstclass) == REG_ANY || OP(RExC_rxi->regstclass) == SANY)) + RExC_rxi->regstclass = NULL; - if ((!(RExC_rx->substrs->data[0].substr || RExC_rx->substrs->data[0].utf8_substr) + if ((!(RExC_rx->substrs->data[0].substr || RExC_rx->substrs->data[0].utf8_substr) || RExC_rx->substrs->data[0].min_offset) - && stclass_flag + && stclass_flag && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING) - && is_ssc_worth_it(pRExC_state, data.start_class)) - { - const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); + && is_ssc_worth_it(pRExC_state, data.start_class)) + { + const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); ssc_finalize(pRExC_state, data.start_class); - Newx(RExC_rxi->data->data[n], 1, regnode_ssc); - StructCopy(data.start_class, - (regnode_ssc*)RExC_rxi->data->data[n], - regnode_ssc); - RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n]; - RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ - DEBUG_COMPILE_r({ SV *sv = sv_newmortal(); + Newx(RExC_rxi->data->data[n], 1, regnode_ssc); + StructCopy(data.start_class, + (regnode_ssc*)RExC_rxi->data->data[n], + regnode_ssc); + RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n]; + RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ + DEBUG_COMPILE_r({ SV *sv = sv_newmortal(); regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state); Perl_re_printf( aTHX_ - "synthetic stclass \"%s\".\n", - SvPVX_const(sv));}); + "synthetic stclass \"%s\".\n", + SvPVX_const(sv));}); data.start_class = NULL; - } + } /* A temporary algorithm prefers floated substr to fixed one of * same length to dig more info. */ - i = (longest_length[0] <= longest_length[1]); + i = (longest_length[0] <= longest_length[1]); RExC_rx->substrs->check_ix = i; RExC_rx->check_end_shift = RExC_rx->substrs->data[i].end_shift; RExC_rx->check_substr = RExC_rx->substrs->data[i].substr; @@ -8305,38 +8305,38 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, if (!i && (RExC_rx->intflags & (PREGf_ANCH_SBOL|PREGf_ANCH_GPOS))) RExC_rx->intflags |= PREGf_NOSCAN; - if ((RExC_rx->check_substr || RExC_rx->check_utf8) ) { - RExC_rx->extflags |= RXf_USE_INTUIT; - if (SvTAIL(RExC_rx->check_substr ? RExC_rx->check_substr : RExC_rx->check_utf8)) - RExC_rx->extflags |= RXf_INTUIT_TAIL; - } + if ((RExC_rx->check_substr || RExC_rx->check_utf8) ) { + RExC_rx->extflags |= RXf_USE_INTUIT; + if (SvTAIL(RExC_rx->check_substr ? RExC_rx->check_substr : RExC_rx->check_utf8)) + RExC_rx->extflags |= RXf_INTUIT_TAIL; + } - /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere) - if ( (STRLEN)minlen < longest_length[1] ) + /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere) + if ( (STRLEN)minlen < longest_length[1] ) minlen= longest_length[1]; if ( (STRLEN)minlen < longest_length[0] ) minlen= longest_length[0]; */ } else { - /* Several toplevels. Best we can is to set minlen. */ - SSize_t fake; - regnode_ssc ch_class; - SSize_t last_close = 0; + /* Several toplevels. Best we can is to set minlen. */ + SSize_t fake; + regnode_ssc ch_class; + SSize_t last_close = 0; DEBUG_PARSE_r(Perl_re_printf( aTHX_ "\nMulti Top Level\n")); - scan = RExC_rxi->program + 1; - ssc_init(pRExC_state, &ch_class); - data.start_class = &ch_class; - data.last_closep = &last_close; + scan = RExC_rxi->program + 1; + ssc_init(pRExC_state, &ch_class); + data.start_class = &ch_class; + data.last_closep = &last_close; DEBUG_RExC_seen(); /* * MAIN ENTRY FOR study_chunk() FOR m/P1|P2|.../ * (patterns WITH top level branches) */ - minlen = study_chunk(pRExC_state, + minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size, &data, -1, 0, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS|(restudied ? SCF_TRIE_DOING_RESTUDY @@ -8345,7 +8345,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, CHECK_RESTUDY_GOTO_butfirst(NOOP); - RExC_rx->check_substr = NULL; + RExC_rx->check_substr = NULL; RExC_rx->check_utf8 = NULL; RExC_rx->substrs->data[0].substr = NULL; RExC_rx->substrs->data[0].utf8_substr = NULL; @@ -8353,25 +8353,25 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_rx->substrs->data[1].utf8_substr = NULL; if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING) - && is_ssc_worth_it(pRExC_state, data.start_class)) + && is_ssc_worth_it(pRExC_state, data.start_class)) { - const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); + const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); ssc_finalize(pRExC_state, data.start_class); - Newx(RExC_rxi->data->data[n], 1, regnode_ssc); - StructCopy(data.start_class, - (regnode_ssc*)RExC_rxi->data->data[n], - regnode_ssc); - RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n]; - RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ - DEBUG_COMPILE_r({ SV* sv = sv_newmortal(); + Newx(RExC_rxi->data->data[n], 1, regnode_ssc); + StructCopy(data.start_class, + (regnode_ssc*)RExC_rxi->data->data[n], + regnode_ssc); + RExC_rxi->regstclass = (regnode*)RExC_rxi->data->data[n]; + RExC_rx->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */ + DEBUG_COMPILE_r({ SV* sv = sv_newmortal(); regprop(RExC_rx, sv, (regnode*)data.start_class, NULL, pRExC_state); Perl_re_printf( aTHX_ - "synthetic stclass \"%s\".\n", - SvPVX_const(sv));}); + "synthetic stclass \"%s\".\n", + SvPVX_const(sv));}); data.start_class = NULL; - } + } } if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN) { @@ -8402,16 +8402,16 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* inplace might break the lookbehind */ if (pRExC_state->code_blocks) - RExC_rx->extflags |= RXf_EVAL_SEEN; + RExC_rx->extflags |= RXf_EVAL_SEEN; if (RExC_seen & REG_VERBARG_SEEN) { - RExC_rx->intflags |= PREGf_VERBARG_SEEN; + RExC_rx->intflags |= PREGf_VERBARG_SEEN; RExC_rx->extflags |= RXf_NO_INPLACE_SUBST; /* don't understand this! Yves */ } if (RExC_seen & REG_CUTGROUP_SEEN) - RExC_rx->intflags |= PREGf_CUTGROUP_SEEN; + RExC_rx->intflags |= PREGf_CUTGROUP_SEEN; if (pm_flags & PMf_USE_RE_EVAL) - RExC_rx->intflags |= PREGf_USE_RE_EVAL; + RExC_rx->intflags |= PREGf_USE_RE_EVAL; if (RExC_paren_names) RXp_PAREN_NAMES(RExC_rx) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names)); else @@ -8567,7 +8567,7 @@ Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey, SV* Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv, - const U32 flags) + const U32 flags) { SV *ret; struct regexp *const rx = ReANY(r); @@ -8616,9 +8616,9 @@ Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key, if (flags & RXapif_ALL) { return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0); } else { - SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags); + SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags); if (sv) { - SvREFCNT_dec_NN(sv); + SvREFCNT_dec_NN(sv); return TRUE; } else { return FALSE; @@ -8637,11 +8637,11 @@ Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags) PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY; if ( rx && RXp_PAREN_NAMES(rx) ) { - (void)hv_iterinit(RXp_PAREN_NAMES(rx)); + (void)hv_iterinit(RXp_PAREN_NAMES(rx)); - return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY); + return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY); } else { - return FALSE; + return FALSE; } } @@ -8671,7 +8671,7 @@ Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags) } } if (parno || flags & RXapif_ALL) { - return newSVhek(HeKEY_hek(temphe)); + return newSVhek(HeKEY_hek(temphe)); } } } @@ -8695,7 +8695,7 @@ Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags) ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES)); av = MUTABLE_AV(SvRV(ret)); length = av_count(av); - SvREFCNT_dec_NN(ret); + SvREFCNT_dec_NN(ret); return newSViv(length); } else { Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", @@ -8743,7 +8743,7 @@ Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags) void Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, - SV * const sv) + SV * const sv) { struct regexp *const rx = ReANY(r); char *s = NULL; @@ -8782,16 +8782,16 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, && rx->offs[0].start != -1) { /* $`, ${^PREMATCH} */ - i = rx->offs[0].start; - s = rx->subbeg; + i = rx->offs[0].start; + s = rx->subbeg; } else if ((n == RX_BUFF_IDX_POSTMATCH || n == RX_BUFF_IDX_CARET_POSTMATCH) && rx->offs[0].end != -1) { /* $', ${^POSTMATCH} */ - s = rx->subbeg - rx->suboffset + rx->offs[0].end; - i = rx->sublen + rx->suboffset - rx->offs[0].end; + s = rx->subbeg - rx->suboffset + rx->offs[0].end; + i = rx->sublen + rx->suboffset - rx->offs[0].end; } else if (inRANGE(n, 0, (I32)rx->nparens) && @@ -8848,7 +8848,7 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, void Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren, - SV const * const value) + SV const * const value) { PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE; @@ -8893,32 +8893,32 @@ Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv, case RX_BUFF_IDX_CARET_PREMATCH: /* ${^PREMATCH} */ case RX_BUFF_IDX_PREMATCH: /* $` */ if (rx->offs[0].start != -1) { - i = rx->offs[0].start; - if (i > 0) { - s1 = 0; - t1 = i; - goto getlen; - } - } + i = rx->offs[0].start; + if (i > 0) { + s1 = 0; + t1 = i; + goto getlen; + } + } return 0; case RX_BUFF_IDX_CARET_POSTMATCH: /* ${^POSTMATCH} */ case RX_BUFF_IDX_POSTMATCH: /* $' */ - if (rx->offs[0].end != -1) { - i = rx->sublen - rx->offs[0].end; - if (i > 0) { - s1 = rx->offs[0].end; - t1 = rx->sublen; - goto getlen; - } - } + if (rx->offs[0].end != -1) { + i = rx->sublen - rx->offs[0].end; + if (i > 0) { + s1 = rx->offs[0].end; + t1 = rx->sublen; + goto getlen; + } + } return 0; default: /* $& / ${^MATCH}, $1, $2, ... */ - if (paren <= (I32)rx->nparens && + if (paren <= (I32)rx->nparens && (s1 = rx->offs[paren].start) != -1 && (t1 = rx->offs[paren].end) != -1) - { + { i = t1 - s1; goto getlen; } else { @@ -8945,11 +8945,11 @@ SV* Perl_reg_qr_package(pTHX_ REGEXP * const rx) { PERL_ARGS_ASSERT_REG_QR_PACKAGE; - PERL_UNUSED_ARG(rx); - if (0) - return NULL; - else - return newSVpvs("Regexp"); + PERL_UNUSED_ARG(rx); + if (0) + return NULL; + else + return newSVpvs("Regexp"); } /* Scans the name of a named buffer from the pattern. @@ -8977,22 +8977,22 @@ S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) else if (isIDFIRST_lazy_if_safe(RExC_parse, RExC_end, UTF)) { /* Note that the code here assumes well-formed UTF-8. Skip IDFIRST by * using do...while */ - if (UTF) - do { - RExC_parse += UTF8SKIP(RExC_parse); - } while ( RExC_parse < RExC_end + if (UTF) + do { + RExC_parse += UTF8SKIP(RExC_parse); + } while ( RExC_parse < RExC_end && isWORDCHAR_utf8_safe((U8*)RExC_parse, (U8*) RExC_end)); - else - do { - RExC_parse++; - } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse)); + else + do { + RExC_parse++; + } while (RExC_parse < RExC_end && isWORDCHAR(*RExC_parse)); } else { RExC_parse++; /* so the <- from the vFAIL is after the offending character */ vFAIL("Group name must start with a non-digit word character"); } sv_name = newSVpvn_flags(name_start, (int)(RExC_parse - name_start), - SVs_TEMP | (UTF ? SVf_UTF8 : 0)); + SVs_TEMP | (UTF ? SVf_UTF8 : 0)); if ( flags == REG_RSN_RETURN_NAME) return sv_name; else if (flags==REG_RSN_RETURN_DATA) { @@ -9312,7 +9312,7 @@ Perl__new_invlist(pTHX_ IV initial_size) SV* new_list; if (initial_size < 0) { - initial_size = 10; + initial_size = 10; } new_list = newSV_type(SVt_INVLIST); @@ -9358,7 +9358,7 @@ Perl__new_invlist_C_array(pTHX_ const UV* const list) SvPV_set(invlist, (char *) (list + HEADER_LENGTH)); SvLEN_set(invlist, 0); /* Means we own the contents, and the system - shouldn't touch it */ + shouldn't touch it */ *(get_invlist_offset_addr(invlist)) = offset; @@ -9398,39 +9398,39 @@ S__append_range_to_invlist(pTHX_ SV* const invlist, array = _invlist_array_init(invlist, ! offset); } else { - /* Here, the existing list is non-empty. The current max entry in the - * list is generally the first value not in the set, except when the - * set extends to the end of permissible values, in which case it is - * the first entry in that final set, and so this call is an attempt to - * append out-of-order */ - - UV final_element = len - 1; - array = invlist_array(invlist); - if ( array[final_element] > start - || ELEMENT_RANGE_MATCHES_INVLIST(final_element)) - { - Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list, final=%" UVuf ", start=%" UVuf ", match=%c", - array[final_element], start, - ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f'); - } + /* Here, the existing list is non-empty. The current max entry in the + * list is generally the first value not in the set, except when the + * set extends to the end of permissible values, in which case it is + * the first entry in that final set, and so this call is an attempt to + * append out-of-order */ + + UV final_element = len - 1; + array = invlist_array(invlist); + if ( array[final_element] > start + || ELEMENT_RANGE_MATCHES_INVLIST(final_element)) + { + Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list, final=%" UVuf ", start=%" UVuf ", match=%c", + array[final_element], start, + ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f'); + } /* Here, it is a legal append. If the new range begins 1 above the end * of the range below it, it is extending the range below it, so the * new first value not in the set is one greater than the newly * extended range. */ offset = *get_invlist_offset_addr(invlist); - if (array[final_element] == start) { - if (end != UV_MAX) { - array[final_element] = end + 1; - } - else { - /* But if the end is the maximum representable on the machine, + if (array[final_element] == start) { + if (end != UV_MAX) { + array[final_element] = end + 1; + } + else { + /* But if the end is the maximum representable on the machine, * assume that infinity was actually what was meant. Just let * the range that this would extend to have no end */ - invlist_set_len(invlist, len - 1, offset); - } - return; - } + invlist_set_len(invlist, len - 1, offset); + } + return; + } } /* Here the new range doesn't extend any existing set. Add it */ @@ -9440,27 +9440,27 @@ S__append_range_to_invlist(pTHX_ SV* const invlist, /* If wll overflow the existing space, extend, which may cause the array to * be moved */ if (max < len) { - invlist_extend(invlist, len); + invlist_extend(invlist, len); /* Have to set len here to avoid assert failure in invlist_array() */ invlist_set_len(invlist, len, offset); - array = invlist_array(invlist); + array = invlist_array(invlist); } else { - invlist_set_len(invlist, len, offset); + invlist_set_len(invlist, len, offset); } /* The next item on the list starts the range, the one after that is * one past the new range. */ array[len - 2] = start; if (end != UV_MAX) { - array[len - 1] = end + 1; + array[len - 1] = end + 1; } else { - /* But if the end is the maximum representable on the machine, just let - * the range have no end */ - invlist_set_len(invlist, len - 1, offset); + /* But if the end is the maximum representable on the machine, just let + * the range have no end */ + invlist_set_len(invlist, len - 1, offset); } } @@ -9484,7 +9484,7 @@ Perl__invlist_search(SV* const invlist, const UV cp) /* If list is empty, return failure. */ if (high == 0) { - return -1; + return -1; } /* (We can't get the array unless we know the list is non-empty) */ @@ -9535,20 +9535,20 @@ Perl__invlist_search(SV* const invlist, const UV cp) * The loop below converges on the i+1. Note that there may not be an * (i+1)th element in the array, and things work nonetheless */ while (low < high) { - mid = (low + high) / 2; + mid = (low + high) / 2; assert(mid <= highest_element); - if (array[mid] <= cp) { /* cp >= array[mid] */ - low = mid + 1; + if (array[mid] <= cp) { /* cp >= array[mid] */ + low = mid + 1; - /* We could do this extra test to exit the loop early. - if (cp < array[low]) { - return mid; - } - */ - } - else { /* cp < array[mid] */ - high = mid; - } + /* We could do this extra test to exit the loop early. + if (cp < array[low]) { + return mid; + } + */ + } + else { /* cp < array[mid] */ + high = mid; + } } found_entry: @@ -9681,7 +9681,7 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, SvREFCNT_dec_NN(u); } - return; + return; } /* Here both lists exist and are non-empty */ @@ -9692,8 +9692,8 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * up so are looking at b's complement. */ if (complement_b) { - /* To complement, we invert: if the first element is 0, remove it. To - * do this, we just pretend the array starts one later */ + /* To complement, we invert: if the first element is 0, remove it. To + * do this, we just pretend the array starts one later */ if (array_b[0] == 0) { array_b++; len_b--; @@ -9718,11 +9718,11 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, /* Go through each input list item by item, stopping when have exhausted * one of them */ while (i_a < len_a && i_b < len_b) { - UV cp; /* The element to potentially add to the union's array */ - bool cp_in_set; /* is it in the input list's set or not */ + UV cp; /* The element to potentially add to the union's array */ + bool cp_in_set; /* is it in the input list's set or not */ - /* We need to take one or the other of the two inputs for the union. - * Since we are merging two sorted lists, we take the smaller of the + /* We need to take one or the other of the two inputs for the union. + * Since we are merging two sorted lists, we take the smaller of the * next items. In case of a tie, we take first the one that is in its * set. If we first took the one not in its set, it would decrement * the count, possibly to 0 which would cause it to be output as ending @@ -9732,33 +9732,33 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * momentarily decremented to 0, and thus the two adjoining ranges will * be seamlessly merged. (In a tie and both are in the set or both not * in the set, it doesn't matter which we take first.) */ - if ( array_a[i_a] < array_b[i_b] - || ( array_a[i_a] == array_b[i_b] - && ELEMENT_RANGE_MATCHES_INVLIST(i_a))) - { - cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a); - cp = array_a[i_a++]; - } - else { - cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b); - cp = array_b[i_b++]; - } - - /* Here, have chosen which of the two inputs to look at. Only output - * if the running count changes to/from 0, which marks the - * beginning/end of a range that's in the set */ - if (cp_in_set) { - if (count == 0) { - array_u[i_u++] = cp; - } - count++; - } - else { - count--; - if (count == 0) { - array_u[i_u++] = cp; - } - } + if ( array_a[i_a] < array_b[i_b] + || ( array_a[i_a] == array_b[i_b] + && ELEMENT_RANGE_MATCHES_INVLIST(i_a))) + { + cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a); + cp = array_a[i_a++]; + } + else { + cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b); + cp = array_b[i_b++]; + } + + /* Here, have chosen which of the two inputs to look at. Only output + * if the running count changes to/from 0, which marks the + * beginning/end of a range that's in the set */ + if (cp_in_set) { + if (count == 0) { + array_u[i_u++] = cp; + } + count++; + } + else { + count--; + if (count == 0) { + array_u[i_u++] = cp; + } + } } @@ -9769,9 +9769,9 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * that list is in its set. (i_a and i_b each currently index the element * beyond the one we care about.) */ if ( (i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a)) - || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b))) + || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b))) { - count--; + count--; } /* Above we decremented 'count' if the list that had unexamined elements in @@ -9801,11 +9801,11 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, else { IV copy_count = len_a - i_a; if (copy_count > 0) { /* The non-exhausted input is 'a' */ - Copy(array_a + i_a, array_u + i_u, copy_count, UV); + Copy(array_a + i_a, array_u + i_u, copy_count, UV); } else { /* The non-exhausted input is b */ copy_count = len_b - i_b; - Copy(array_b + i_b, array_u + i_u, copy_count, UV); + Copy(array_b + i_b, array_u + i_u, copy_count, UV); } len_u = i_u + copy_count; } @@ -9814,9 +9814,9 @@ Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * array_u, so re-find it. (Note that it is unlikely that this will * change, as we are shrinking the space, not enlarging it) */ if (len_u != _invlist_len(u)) { - invlist_set_len(u, len_u, *get_invlist_offset_addr(u)); - invlist_trim(u); - array_u = invlist_array(u); + invlist_set_len(u, len_u, *get_invlist_offset_addr(u)); + invlist_trim(u); + array_u = invlist_array(u); } if (*output == NULL) { /* Simply return the new inversion list */ @@ -9914,7 +9914,7 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, } invlist_clear(*i); - return; + return; } /* Here both lists exist and are non-empty */ @@ -9925,8 +9925,8 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * up so are looking at b's complement. */ if (complement_b) { - /* To complement, we invert: if the first element is 0, remove it. To - * do this, we just pretend the array starts one later */ + /* To complement, we invert: if the first element is 0, remove it. To + * do this, we just pretend the array starts one later */ if (array_b[0] == 0) { array_b++; len_b--; @@ -9951,12 +9951,12 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, /* Go through each list item by item, stopping when have exhausted one of * them */ while (i_a < len_a && i_b < len_b) { - UV cp; /* The element to potentially add to the intersection's - array */ - bool cp_in_set; /* Is it in the input list's set or not */ + UV cp; /* The element to potentially add to the intersection's + array */ + bool cp_in_set; /* Is it in the input list's set or not */ - /* We need to take one or the other of the two inputs for the - * intersection. Since we are merging two sorted lists, we take the + /* We need to take one or the other of the two inputs for the + * intersection. Since we are merging two sorted lists, we take the * smaller of the next items. In case of a tie, we take first the one * that is not in its set (a difference from the union algorithm). If * we first took the one in its set, it would increment the count, @@ -9966,33 +9966,33 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * opposite of this, there is no possibility that the count will be * momentarily incremented to 2. (In a tie and both are in the set or * both not in the set, it doesn't matter which we take first.) */ - if ( array_a[i_a] < array_b[i_b] - || ( array_a[i_a] == array_b[i_b] - && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a))) - { - cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a); - cp = array_a[i_a++]; - } - else { - cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b); - cp= array_b[i_b++]; - } - - /* Here, have chosen which of the two inputs to look at. Only output - * if the running count changes to/from 2, which marks the - * beginning/end of a range that's in the intersection */ - if (cp_in_set) { - count++; - if (count == 2) { - array_r[i_r++] = cp; - } - } - else { - if (count == 2) { - array_r[i_r++] = cp; - } - count--; - } + if ( array_a[i_a] < array_b[i_b] + || ( array_a[i_a] == array_b[i_b] + && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a))) + { + cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a); + cp = array_a[i_a++]; + } + else { + cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b); + cp= array_b[i_b++]; + } + + /* Here, have chosen which of the two inputs to look at. Only output + * if the running count changes to/from 2, which marks the + * beginning/end of a range that's in the intersection */ + if (cp_in_set) { + count++; + if (count == 2) { + array_r[i_r++] = cp; + } + } + else { + if (count == 2) { + array_r[i_r++] = cp; + } + count--; + } } @@ -10005,7 +10005,7 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, if ( (i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a)) || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b))) { - count++; + count++; } /* Above we incremented 'count' if the exhausted list was in its set. This @@ -10035,11 +10035,11 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, else { /* copy the non-exhausted list, unchanged. */ IV copy_count = len_a - i_a; if (copy_count > 0) { /* a is the one with stuff left */ - Copy(array_a + i_a, array_r + i_r, copy_count, UV); + Copy(array_a + i_a, array_r + i_r, copy_count, UV); } else { /* b is the one with stuff left */ copy_count = len_b - i_b; - Copy(array_b + i_b, array_r + i_r, copy_count, UV); + Copy(array_b + i_b, array_r + i_r, copy_count, UV); } len_r = i_r + copy_count; } @@ -10048,9 +10048,9 @@ Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, * array_r, so re-find it. (Note that it is unlikely that this will * change, as we are shrinking the space, not enlarging it) */ if (len_r != _invlist_len(r)) { - invlist_set_len(r, len_r, *get_invlist_offset_addr(r)); - invlist_trim(r); - array_r = invlist_array(r); + invlist_set_len(r, len_r, *get_invlist_offset_addr(r)); + invlist_trim(r); + array_r = invlist_array(r); } if (*i == NULL) { /* Simply return the calculated intersection */ @@ -10099,7 +10099,7 @@ Perl__add_range_to_invlist(pTHX_ SV* invlist, UV start, UV end) /* This range becomes the whole inversion list if none already existed */ if (invlist == NULL) { - invlist = _new_invlist(2); + invlist = _new_invlist(2); _append_range_to_invlist(invlist, start, end); return invlist; } @@ -10378,8 +10378,8 @@ Perl__invlist_invert(pTHX_ SV* const invlist) /* The inverse of matching nothing is matching everything */ if (_invlist_len(invlist) == 0) { - _append_range_to_invlist(invlist, 0, UV_MAX); - return; + _append_range_to_invlist(invlist, 0, UV_MAX); + return; } *get_invlist_offset_addr(invlist) = ! *get_invlist_offset_addr(invlist); @@ -10463,21 +10463,21 @@ S_invlist_contents(pTHX_ SV* const invlist, const bool traditional_style) invlist_iterinit(invlist); while (invlist_iternext(invlist, &start, &end)) { - if (end == UV_MAX) { - Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFTY%c", + if (end == UV_MAX) { + Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%cINFTY%c", start, intra_range_delimiter, inter_range_delimiter); - } - else if (end != start) { - Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c", - start, + } + else if (end != start) { + Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c%04" UVXf "%c", + start, intra_range_delimiter, end, inter_range_delimiter); - } - else { - Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c", + } + else { + Perl_sv_catpvf(aTHX_ output, "%04" UVXf "%c", start, inter_range_delimiter); - } + } } if (SvCUR(output) && ! traditional_style) {/* Get rid of trailing blank */ @@ -10520,20 +10520,20 @@ Perl__invlist_dump(pTHX_ PerlIO *file, I32 level, invlist_iterinit(invlist); while (invlist_iternext(invlist, &start, &end)) { - if (end == UV_MAX) { - Perl_dump_indent(aTHX_ level, file, + if (end == UV_MAX) { + Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf " .. INFTY\n", indent, (UV)count, start); - } - else if (end != start) { - Perl_dump_indent(aTHX_ level, file, + } + else if (end != start) { + Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf " .. 0x%04" UVXf "\n", - indent, (UV)count, start, end); - } - else { - Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n", + indent, (UV)count, start, end); + } + else { + Perl_dump_indent(aTHX_ level, file, "%s[%" UVuf "] 0x%04" UVXf "\n", indent, (UV)count, start); - } + } count += 2; } } @@ -10939,7 +10939,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) : WASTED_G; if (! (wastedflags & wflagbit) ) { wastedflags |= wflagbit; - /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ + /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ vWARN5( RExC_parse + 1, "Useless (%s%c) - %suse /%c modifier", @@ -10959,7 +10959,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) if (ckWARN(WARN_REGEXP)) { if (! (wastedflags & WASTED_C) ) { wastedflags |= WASTED_GC; - /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ + /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ vWARN3( RExC_parse + 1, "Useless (%sc) - %suse /gc modifier", @@ -11020,7 +11020,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) default: fail_modifiers: RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end); - /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */ + /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */ vFAIL2utf8f("Sequence (%" UTF8f "...) not recognized", UTF8fARG(UTF, RExC_parse-seqstart, seqstart)); NOT_REACHED; /*NOTREACHED*/ @@ -11171,7 +11171,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) && *(RExC_parse - 1) != '('; if (RExC_parse >= RExC_end) { - vFAIL("Unmatched ("); + vFAIL("Unmatched ("); } if (paren == 'r') { /* Atomic script run */ @@ -11179,10 +11179,10 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) goto parse_rest; } else if ( *RExC_parse == '*') { /* (*VERB:ARG), (*construct:...) */ - char *start_verb = RExC_parse + 1; - STRLEN verb_len; - char *start_arg = NULL; - unsigned char op = 0; + char *start_verb = RExC_parse + 1; + STRLEN verb_len; + char *start_arg = NULL; + unsigned char op = 0; int arg_required = 0; int internal_argval = -1; /* if >-1 we are not allowed an argument*/ bool has_upper = FALSE; @@ -11199,11 +11199,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL("In '(*...)', the '(' and '*' must be adjacent"); } } - while (RExC_parse < RExC_end && *RExC_parse != ')' ) { - if ( *RExC_parse == ':' ) { - start_arg = RExC_parse + 1; - break; - } + while (RExC_parse < RExC_end && *RExC_parse != ')' ) { + if ( *RExC_parse == ':' ) { + start_arg = RExC_parse + 1; + break; + } else if (! UTF) { if (isUPPER(*RExC_parse)) { has_upper = TRUE; @@ -11213,18 +11213,18 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) else { RExC_parse += UTF8SKIP(RExC_parse); } - } - verb_len = RExC_parse - start_verb; - if ( start_arg ) { + } + verb_len = RExC_parse - start_verb; + if ( start_arg ) { if (RExC_parse >= RExC_end) { goto unterminated_verb_pattern; } - RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; - while ( RExC_parse < RExC_end && *RExC_parse != ')' ) { + RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; + while ( RExC_parse < RExC_end && *RExC_parse != ')' ) { RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; } - if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) { + if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) { unterminated_verb_pattern: if (has_upper) { vFAIL("Unterminated verb pattern argument"); @@ -11233,8 +11233,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL("Unterminated '(*...' argument"); } } - } else { - if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) { + } else { + if ( RExC_parse >= RExC_end || *RExC_parse != ')' ) { if (has_upper) { vFAIL("Unterminated verb pattern"); } @@ -11242,29 +11242,29 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL("Unterminated '(*...' construct"); } } - } + } /* Here, we know that RExC_parse < RExC_end */ - switch ( *start_verb ) { + switch ( *start_verb ) { case 'A': /* (*ACCEPT) */ if ( memEQs(start_verb, verb_len,"ACCEPT") ) { - op = ACCEPT; - internal_argval = RExC_nestroot; - } - break; + op = ACCEPT; + internal_argval = RExC_nestroot; + } + break; case 'C': /* (*COMMIT) */ if ( memEQs(start_verb, verb_len,"COMMIT") ) op = COMMIT; break; case 'F': /* (*FAIL) */ if ( verb_len==1 || memEQs(start_verb, verb_len,"FAIL") ) { - op = OPFAIL; - } - break; + op = OPFAIL; + } + break; case ':': /* (*:NAME) */ - case 'M': /* (*MARK:NAME) */ - if ( verb_len==0 || memEQs(start_verb, verb_len,"MARK") ) { + case 'M': /* (*MARK:NAME) */ + if ( verb_len==0 || memEQs(start_verb, verb_len,"MARK") ) { op = MARKPOINT; arg_required = 1; } @@ -11421,7 +11421,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) ret=reganode(pRExC_state, OPFAIL, 0); nextchar(pRExC_state); return ret; - } + } RExC_parse = start_arg; goto parse_rest; @@ -11430,11 +11430,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL2utf8f( "'(*%" UTF8f "' requires a terminating ':'", UTF8fARG(UTF, verb_len, start_verb)); - NOT_REACHED; /*NOTREACHED*/ + NOT_REACHED; /*NOTREACHED*/ - } /* End of switch */ - if ( ! op ) { - RExC_parse += UTF + } /* End of switch */ + if ( ! op ) { + RExC_parse += UTF ? UTF8_SAFE_SKIP(RExC_parse, RExC_end) : 1; if (has_upper || verb_len == 0) { @@ -11447,7 +11447,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) "Unknown '(*...)' construct '%" UTF8f "'", UTF8fARG(UTF, verb_len, start_verb)); } - } + } if ( RExC_parse == start_arg ) { start_arg = NULL; } @@ -11473,12 +11473,12 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } if ( internal_argval != -1 ) ARG2L_SET(REGNODE_p(ret), internal_argval); - nextchar(pRExC_state); - return ret; + nextchar(pRExC_state); + return ret; } else if (*RExC_parse == '?') { /* (?...) */ - bool is_logical = 0; - const char * const seqstart = RExC_parse; + bool is_logical = 0; + const char * const seqstart = RExC_parse; const char * endptr; const char non_existent_group_msg[] = "Reference to nonexistent group"; @@ -11489,24 +11489,24 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) vFAIL("In '(?...)', the '(' and '?' must be adjacent"); } - RExC_parse++; /* past the '?' */ + RExC_parse++; /* past the '?' */ paren = *RExC_parse; /* might be a trailing NUL, if not well-formed */ RExC_parse += UTF ? UTF8SKIP(RExC_parse) : 1; if (RExC_parse > RExC_end) { paren = '\0'; } - ret = 0; /* For look-ahead/behind. */ - switch (paren) { + ret = 0; /* For look-ahead/behind. */ + switch (paren) { - case 'P': /* (?P...) variants for those used to PCRE/Python */ - paren = *RExC_parse; - if ( paren == '<') { /* (?P<...>) named capture */ + case 'P': /* (?P...) variants for those used to PCRE/Python */ + paren = *RExC_parse; + if ( paren == '<') { /* (?P<...>) named capture */ RExC_parse++; if (RExC_parse >= RExC_end) { vFAIL("Sequence (?P<... not terminated"); } - goto named_capture; + goto named_capture; } else if (paren == '>') { /* (?P>name) named recursion */ RExC_parse++; @@ -11522,33 +11522,33 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end); /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */ - vFAIL3("Sequence (%.*s...) not recognized", + vFAIL3("Sequence (%.*s...) not recognized", (int) (RExC_parse - seqstart), seqstart); - NOT_REACHED; /*NOTREACHED*/ + NOT_REACHED; /*NOTREACHED*/ case '<': /* (?<...) */ /* If you want to support (?<*...), first reconcile with GH #17363 */ - if (*RExC_parse == '!') - paren = ','; - else if (*RExC_parse != '=') + if (*RExC_parse == '!') + paren = ','; + else if (*RExC_parse != '=') named_capture: - { /* (?<...>) */ - char *name_start; - SV *svname; - paren= '>'; + { /* (?<...>) */ + char *name_start; + SV *svname; + paren= '>'; /* FALLTHROUGH */ case '\'': /* (?'...') */ name_start = RExC_parse; svname = reg_scan_name(pRExC_state, REG_RSN_RETURN_NAME); - if ( RExC_parse == name_start + if ( RExC_parse == name_start || RExC_parse >= RExC_end || *RExC_parse != paren) { - vFAIL2("Sequence (?%c... not terminated", - paren=='>' ? '<' : (char) paren); + vFAIL2("Sequence (?%c... not terminated", + paren=='>' ? '<' : (char) paren); } - { - HE *he_str; - SV *sv_dat = NULL; + { + HE *he_str; + SV *sv_dat = NULL; if (!svname) /* shouldn't happen */ Perl_croak(aTHX_ "panic: reg_scan_name returned NULL"); @@ -11607,56 +11607,56 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) /*sv_dump(sv_dat);*/ } nextchar(pRExC_state); - paren = 1; - goto capturing_parens; - } + paren = 1; + goto capturing_parens; + } RExC_seen |= REG_LOOKBEHIND_SEEN; - RExC_in_lookaround++; - RExC_parse++; + RExC_in_lookaround++; + RExC_parse++; if (RExC_parse >= RExC_end) { vFAIL("Sequence (?... not terminated"); } RExC_seen_zerolen++; break; - case '=': /* (?=...) */ - RExC_seen_zerolen++; + case '=': /* (?=...) */ + RExC_seen_zerolen++; RExC_in_lookaround++; break; - case '!': /* (?!...) */ - RExC_seen_zerolen++; - /* check if we're really just a "FAIL" assertion */ + case '!': /* (?!...) */ + RExC_seen_zerolen++; + /* check if we're really just a "FAIL" assertion */ skip_to_be_ignored_text(pRExC_state, &RExC_parse, FALSE /* Don't force to /x */ ); - if (*RExC_parse == ')') { + if (*RExC_parse == ')') { ret=reganode(pRExC_state, OPFAIL, 0); - nextchar(pRExC_state); - return ret; - } + nextchar(pRExC_state); + return ret; + } RExC_in_lookaround++; - break; - case '|': /* (?|...) */ - /* branch reset, behave like a (?:...) except that - buffers in alternations share the same numbers */ - paren = ':'; - after_freeze = freeze_paren = RExC_npar; + break; + case '|': /* (?|...) */ + /* branch reset, behave like a (?:...) except that + buffers in alternations share the same numbers */ + paren = ':'; + after_freeze = freeze_paren = RExC_npar; /* XXX This construct currently requires an extra pass. * Investigation would be required to see if that could be * changed */ REQUIRE_PARENS_PASS; - break; - case ':': /* (?:...) */ - case '>': /* (?>...) */ - break; - case '$': /* (?$...) */ - case '@': /* (?@...) */ - vFAIL2("Sequence (?%c...) not implemented", (int)paren); - break; - case '0' : /* (?0) */ - case 'R' : /* (?R) */ + break; + case ':': /* (?:...) */ + case '>': /* (?>...) */ + break; + case '$': /* (?$...) */ + case '@': /* (?@...) */ + vFAIL2("Sequence (?%c...) not implemented", (int)paren); + break; + case '0' : /* (?0) */ + case 'R' : /* (?R) */ if (RExC_parse == RExC_end || *RExC_parse != ')') - FAIL("Sequence (?R) not terminated"); + FAIL("Sequence (?R) not terminated"); num = 0; RExC_seen |= REG_RECURSE_SEEN; @@ -11664,9 +11664,9 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) * It probably could be changed */ REQUIRE_PARENS_PASS; - *flagp |= POSTPONED; + *flagp |= POSTPONED; goto gen_recurse_regop; - /*notreached*/ + /*notreached*/ /* named and numeric backreferences */ case '&': /* (?&NAME) */ parse_start = RExC_parse - 1; @@ -11694,8 +11694,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } /* FALLTHROUGH */ case '1': case '2': case '3': case '4': /* (?1) */ - case '5': case '6': case '7': case '8': case '9': - RExC_parse = (char *) seqstart + 1; /* Point to the digit */ + case '5': case '6': case '7': case '8': case '9': + RExC_parse = (char *) seqstart + 1; /* Point to the digit */ parse_recursion: { bool is_neg = FALSE; @@ -11725,8 +11725,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) num = -num; } } - if (*RExC_parse!=')') - vFAIL("Expecting close bracket"); + if (*RExC_parse!=')') + vFAIL("Expecting close bracket"); gen_recurse_regop: if (paren == '-' || paren == '+') { @@ -11801,7 +11801,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) Set_Node_Length(REGNODE_p(ret), 1 + regarglen[OP(REGNODE_p(ret))]); /* MJD */ - Set_Node_Offset(REGNODE_p(ret), parse_start); /* MJD */ + Set_Node_Offset(REGNODE_p(ret), parse_start); /* MJD */ *flagp |= POSTPONED; assert(*RExC_parse == ')'); @@ -11810,43 +11810,43 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) /* NOTREACHED */ - case '?': /* (??...) */ - is_logical = 1; - if (*RExC_parse != '{') { + case '?': /* (??...) */ + is_logical = 1; + if (*RExC_parse != '{') { RExC_parse += SKIP_IF_CHAR(RExC_parse, RExC_end); /* diag_listed_as: Sequence (?%s...) not recognized in regex; marked by <-- HERE in m/%s/ */ vFAIL2utf8f( "Sequence (%" UTF8f "...) not recognized", UTF8fARG(UTF, RExC_parse-seqstart, seqstart)); - NOT_REACHED; /*NOTREACHED*/ - } - *flagp |= POSTPONED; - paren = '{'; + NOT_REACHED; /*NOTREACHED*/ + } + *flagp |= POSTPONED; + paren = '{'; RExC_parse++; - /* FALLTHROUGH */ - case '{': /* (?{...}) */ - { - U32 n = 0; - struct reg_code_block *cb; + /* FALLTHROUGH */ + case '{': /* (?{...}) */ + { + U32 n = 0; + struct reg_code_block *cb; OP * o; - RExC_seen_zerolen++; + RExC_seen_zerolen++; - if ( !pRExC_state->code_blocks - || pRExC_state->code_index + if ( !pRExC_state->code_blocks + || pRExC_state->code_index >= pRExC_state->code_blocks->count - || pRExC_state->code_blocks->cb[pRExC_state->code_index].start - != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0)) - - RExC_start) - ) { - if (RExC_pm_flags & PMf_USE_RE_EVAL) - FAIL("panic: Sequence (?{...}): no code block found\n"); - FAIL("Eval-group not allowed at runtime, use re 'eval'"); - } - /* this is a pre-compiled code block (?{...}) */ - cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index]; - RExC_parse = RExC_start + cb->end; - o = cb->block; + || pRExC_state->code_blocks->cb[pRExC_state->code_index].start + != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0)) + - RExC_start) + ) { + if (RExC_pm_flags & PMf_USE_RE_EVAL) + FAIL("panic: Sequence (?{...}): no code block found\n"); + FAIL("Eval-group not allowed at runtime, use re 'eval'"); + } + /* this is a pre-compiled code block (?{...}) */ + cb = &pRExC_state->code_blocks->cb[pRExC_state->code_index]; + RExC_parse = RExC_start + cb->end; + o = cb->block; if (cb->src_regex) { n = add_data(pRExC_state, STR_WITH_LEN("rl")); RExC_rxi->data->data[n] = @@ -11858,12 +11858,12 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l", 1); RExC_rxi->data->data[n] = (void*)o; } - pRExC_state->code_index++; - nextchar(pRExC_state); + pRExC_state->code_index++; + nextchar(pRExC_state); - if (is_logical) { + if (is_logical) { regnode_offset eval; - ret = reg_node(pRExC_state, LOGICAL); + ret = reg_node(pRExC_state, LOGICAL); eval = reg2Lanode(pRExC_state, EVAL, n, @@ -11877,24 +11877,24 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) REQUIRE_BRANCHJ(flagp, 0); } /* deal with the length of this later - MJD */ - return ret; - } - ret = reg2Lanode(pRExC_state, EVAL, n, 0); - Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1); - Set_Node_Offset(REGNODE_p(ret), parse_start); - return ret; - } - case '(': /* (?(?{...})...) and (?(?=...)...) */ - { - int is_define= 0; + return ret; + } + ret = reg2Lanode(pRExC_state, EVAL, n, 0); + Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1); + Set_Node_Offset(REGNODE_p(ret), parse_start); + return ret; + } + case '(': /* (?(?{...})...) and (?(?=...)...) */ + { + int is_define= 0; const int DEFINE_len = sizeof("DEFINE") - 1; - if ( RExC_parse < RExC_end - 1 + if ( RExC_parse < RExC_end - 1 && ( ( RExC_parse[0] == '?' /* (?(?...)) */ && ( RExC_parse[1] == '=' || RExC_parse[1] == '!' || RExC_parse[1] == '<' || RExC_parse[1] == '{')) - || ( RExC_parse[0] == '*' /* (?(*...)) */ + || ( RExC_parse[0] == '*' /* (?(*...)) */ && ( memBEGINs(RExC_parse + 1, (Size_t) (RExC_end - (RExC_parse + 1)), "pla:") @@ -11933,14 +11933,14 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } goto insert_if; } - else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */ - || RExC_parse[0] == '\'' ) /* (?('NAME')...) */ - { - char ch = RExC_parse[0] == '<' ? '>' : '\''; - char *name_start= RExC_parse++; - U32 num = 0; - SV *sv_dat=reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA); - if ( RExC_parse == name_start + else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */ + || RExC_parse[0] == '\'' ) /* (?('NAME')...) */ + { + char ch = RExC_parse[0] == '<' ? '>' : '\''; + char *name_start= RExC_parse++; + U32 num = 0; + SV *sv_dat=reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA); + if ( RExC_parse == name_start || RExC_parse >= RExC_end || *RExC_parse != ch) { @@ -11955,23 +11955,23 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } ret = reganode(pRExC_state, GROUPPN, num); goto insert_if_check_paren; - } - else if (memBEGINs(RExC_parse, + } + else if (memBEGINs(RExC_parse, (STRLEN) (RExC_end - RExC_parse), "DEFINE")) { - ret = reganode(pRExC_state, DEFINEP, 0); - RExC_parse += DEFINE_len; - is_define = 1; - goto insert_if_check_paren; - } - else if (RExC_parse[0] == 'R') { - RExC_parse++; + ret = reganode(pRExC_state, DEFINEP, 0); + RExC_parse += DEFINE_len; + is_define = 1; + goto insert_if_check_paren; + } + else if (RExC_parse[0] == 'R') { + RExC_parse++; /* parno == 0 => /(?(R)YES|NO)/ "in any form of recursion OR eval" * parno == 1 => /(?(R0)YES|NO)/ "in GOSUB (?0) / (?R)" * parno == 2 => /(?(R1)YES|NO)/ "in GOSUB (?1) (parno-1)" */ - parno = 0; + parno = 0; if (RExC_parse[0] == '0') { parno = 1; RExC_parse++; @@ -11986,20 +11986,20 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) RExC_parse = (char*)endptr; } /* else "Switch condition not recognized" below */ - } else if (RExC_parse[0] == '&') { - SV *sv_dat; - RExC_parse++; - sv_dat = reg_scan_name(pRExC_state, + } else if (RExC_parse[0] == '&') { + SV *sv_dat; + RExC_parse++; + sv_dat = reg_scan_name(pRExC_state, REG_RSN_RETURN_DATA); if (sv_dat) parno = 1 + *((I32 *)SvPVX(sv_dat)); - } - ret = reganode(pRExC_state, INSUBP, parno); - goto insert_if_check_paren; - } + } + ret = reganode(pRExC_state, INSUBP, parno); + goto insert_if_check_paren; + } else if (inRANGE(RExC_parse[0], '1', '9')) { /* (?(1)...) */ - char c; + char c; UV uv; endptr = RExC_end; if (grok_atoUV(RExC_parse, &uv, &endptr) @@ -12014,21 +12014,21 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) ret = reganode(pRExC_state, GROUPP, parno); insert_if_check_paren: - if (UCHARAT(RExC_parse) != ')') { + if (UCHARAT(RExC_parse) != ')') { RExC_parse += UTF ? UTF8_SAFE_SKIP(RExC_parse, RExC_end) : 1; - vFAIL("Switch condition not recognized"); - } - nextchar(pRExC_state); - insert_if: + vFAIL("Switch condition not recognized"); + } + nextchar(pRExC_state); + insert_if: if (! REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0))) { REQUIRE_BRANCHJ(flagp, 0); } br = regbranch(pRExC_state, &flags, 1, depth+1); - if (br == 0) { + if (br == 0) { RETURN_FAIL_ON_RESTART(flags,flagp); FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags); @@ -12038,13 +12038,13 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) { REQUIRE_BRANCHJ(flagp, 0); } - c = UCHARAT(RExC_parse); + c = UCHARAT(RExC_parse); nextchar(pRExC_state); - if (flags&HASWIDTH) - *flagp |= HASWIDTH; - if (c == '|') { - if (is_define) - vFAIL("(?(DEFINE)....) does not allow branches"); + if (flags&HASWIDTH) + *flagp |= HASWIDTH; + if (c == '|') { + if (is_define) + vFAIL("(?(DEFINE)....) does not allow branches"); /* Fake one for optimizer. */ lastbr = reganode(pRExC_state, IFTHEN, 0); @@ -12057,24 +12057,24 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) if (! REGTAIL(pRExC_state, ret, lastbr)) { REQUIRE_BRANCHJ(flagp, 0); } - if (flags&HASWIDTH) - *flagp |= HASWIDTH; + if (flags&HASWIDTH) + *flagp |= HASWIDTH; c = UCHARAT(RExC_parse); nextchar(pRExC_state); - } - else - lastbr = 0; + } + else + lastbr = 0; if (c != ')') { if (RExC_parse >= RExC_end) vFAIL("Switch (?(condition)... not terminated"); else vFAIL("Switch (?(condition)... contains too many branches"); } - ender = reg_node(pRExC_state, TAIL); + ender = reg_node(pRExC_state, TAIL); if (! REGTAIL(pRExC_state, br, ender)) { REQUIRE_BRANCHJ(flagp, 0); } - if (lastbr) { + if (lastbr) { if (! REGTAIL(pRExC_state, lastbr, ender)) { REQUIRE_BRANCHJ(flagp, 0); } @@ -12086,8 +12086,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) { REQUIRE_BRANCHJ(flagp, 0); } - } - else + } + else if (! REGTAIL(pRExC_state, ret, ender)) { REQUIRE_BRANCHJ(flagp, 0); } @@ -12096,18 +12096,18 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) For large programs it seems to be required but I can't figure out why. -- dmq*/ #endif - return ret; - } + return ret; + } RExC_parse += UTF ? UTF8_SAFE_SKIP(RExC_parse, RExC_end) : 1; vFAIL("Unknown switch condition (?(...))"); - } - case '[': /* (?[ ... ]) */ + } + case '[': /* (?[ ... ]) */ return handle_regex_sets(pRExC_state, NULL, flagp, depth+1, oregcomp_parse); case 0: /* A NUL */ - RExC_parse--; /* for vFAIL to print correctly */ + RExC_parse--; /* for vFAIL to print correctly */ vFAIL("Sequence (? incomplete"); break; @@ -12117,11 +12117,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } /* FALLTHROUGH */ case '*': /* If you want to support (?*...), first reconcile with GH #17363 */ - /* FALLTHROUGH */ - default: /* e.g., (?i) */ - RExC_parse = (char *) seqstart + 1; + /* FALLTHROUGH */ + default: /* e.g., (?i) */ + RExC_parse = (char *) seqstart + 1; parse_flags: - parse_lparen_question_flags(pRExC_state); + parse_lparen_question_flags(pRExC_state); if (UCHARAT(RExC_parse) != ':') { if (RExC_parse < RExC_end) nextchar(pRExC_state); @@ -12133,11 +12133,11 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) ret = 0; goto parse_rest; } /* end switch */ - } + } else if (!(RExC_flags & RXf_PMf_NOCAPTURE)) { /* (...) */ - capturing_parens: - parno = RExC_npar; - RExC_npar++; + capturing_parens: + parno = RExC_npar; + RExC_npar++; if (! ALL_PARENS_COUNTED) { /* If we are in our first pass through (and maybe only pass), * we need to allocate memory for the capturing parentheses @@ -12182,7 +12182,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } } - ret = reganode(pRExC_state, OPEN, parno); + ret = reganode(pRExC_state, OPEN, parno); if (!RExC_nestroot) RExC_nestroot = parno; if (RExC_open_parens && !RExC_open_parens[parno]) @@ -12196,15 +12196,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) Set_Node_Length(REGNODE_p(ret), 1); /* MJD */ Set_Node_Offset(REGNODE_p(ret), RExC_parse); /* MJD */ - is_open = 1; - } else { + is_open = 1; + } else { /* with RXf_PMf_NOCAPTURE treat (...) as (?:...) */ paren = ':'; - ret = 0; + ret = 0; } } else /* ! paren */ - ret = 0; + ret = 0; parse_rest: /* Pick up the branches, linking them together. */ @@ -12218,18 +12218,18 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags); } if (*RExC_parse == '|') { - if (RExC_use_BRANCHJ) { - reginsert(pRExC_state, BRANCHJ, br, depth+1); - } - else { /* MJD */ - reginsert(pRExC_state, BRANCH, br, depth+1); + if (RExC_use_BRANCHJ) { + reginsert(pRExC_state, BRANCHJ, br, depth+1); + } + else { /* MJD */ + reginsert(pRExC_state, BRANCH, br, depth+1); Set_Node_Length(REGNODE_p(br), paren != 0); Set_Node_Offset_To_R(br, parse_start-RExC_start); } - have_branch = 1; + have_branch = 1; } else if (paren == ':') { - *flagp |= flags&SIMPLE; + *flagp |= flags&SIMPLE; } if (is_open) { /* Starts with OPEN. */ if (! REGTAIL(pRExC_state, ret, br)) { /* OPEN -> first. */ @@ -12237,82 +12237,82 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) } } else if (paren != '?') /* Not Conditional */ - ret = br; + ret = br; *flagp |= flags & (HASWIDTH | POSTPONED); lastbr = br; while (*RExC_parse == '|') { - if (RExC_use_BRANCHJ) { + if (RExC_use_BRANCHJ) { bool shut_gcc_up; - ender = reganode(pRExC_state, LONGJMP, 0); + ender = reganode(pRExC_state, LONGJMP, 0); /* Append to the previous. */ shut_gcc_up = REGTAIL(pRExC_state, REGNODE_OFFSET(NEXTOPER(NEXTOPER(REGNODE_p(lastbr)))), ender); PERL_UNUSED_VAR(shut_gcc_up); - } - nextchar(pRExC_state); - if (freeze_paren) { - if (RExC_npar > after_freeze) - after_freeze = RExC_npar; + } + nextchar(pRExC_state); + if (freeze_paren) { + if (RExC_npar > after_freeze) + after_freeze = RExC_npar; RExC_npar = freeze_paren; } br = regbranch(pRExC_state, &flags, 0, depth+1); - if (br == 0) { + if (br == 0) { RETURN_FAIL_ON_RESTART(flags, flagp); FAIL2("panic: regbranch returned failure, flags=%#" UVxf, (UV) flags); } if (! REGTAIL(pRExC_state, lastbr, br)) { /* BRANCH -> BRANCH. */ REQUIRE_BRANCHJ(flagp, 0); } - lastbr = br; - *flagp |= flags & (HASWIDTH | POSTPONED); + lastbr = br; + *flagp |= flags & (HASWIDTH | POSTPONED); } if (have_branch || paren != ':') { regnode * br; - /* Make a closing node, and hook it on the end. */ - switch (paren) { - case ':': - ender = reg_node(pRExC_state, TAIL); - break; - case 1: case 2: - ender = reganode(pRExC_state, CLOSE, parno); + /* Make a closing node, and hook it on the end. */ + switch (paren) { + case ':': + ender = reg_node(pRExC_state, TAIL); + break; + case 1: case 2: + ender = reganode(pRExC_state, CLOSE, parno); if ( RExC_close_parens ) { DEBUG_OPTIMISE_MORE_r(Perl_re_printf( aTHX_ "%*s%*s Setting close paren #%" IVdf " to %zu\n", 22, "| |", (int)(depth * 2 + 1), "", (IV)parno, ender)); RExC_close_parens[parno]= ender; - if (RExC_nestroot == parno) - RExC_nestroot = 0; - } + if (RExC_nestroot == parno) + RExC_nestroot = 0; + } Set_Node_Offset(REGNODE_p(ender), RExC_parse+1); /* MJD */ Set_Node_Length(REGNODE_p(ender), 1); /* MJD */ - break; - case 's': - ender = reg_node(pRExC_state, SRCLOSE); + break; + case 's': + ender = reg_node(pRExC_state, SRCLOSE); RExC_in_script_run = 0; - break; - case '<': + break; + case '<': case 'a': case 'A': case 'b': case 'B': - case ',': - case '=': - case '!': - *flagp &= ~HASWIDTH; - /* FALLTHROUGH */ + case ',': + case '=': + case '!': + *flagp &= ~HASWIDTH; + /* FALLTHROUGH */ case 't': /* aTomic */ - case '>': - ender = reg_node(pRExC_state, SUCCEED); - break; - case 0: - ender = reg_node(pRExC_state, END); + case '>': + ender = reg_node(pRExC_state, SUCCEED); + break; + case 0: + ender = reg_node(pRExC_state, END); assert(!RExC_end_op); /* there can only be one! */ RExC_end_op = REGNODE_p(ender); if (RExC_close_parens) { @@ -12323,8 +12323,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) RExC_close_parens[0]= ender; } - break; - } + break; + } DEBUG_PARSE_r({ DEBUG_PARSE_MSG("lsbr"); regprop(RExC_rx, RExC_mysv1, REGNODE_p(lastbr), NULL, pRExC_state); @@ -12341,15 +12341,15 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) REQUIRE_BRANCHJ(flagp, 0); } - if (have_branch) { + if (have_branch) { char is_nothing= 1; - if (depth==1) + if (depth==1) RExC_seen |= REG_TOP_LEVEL_BRANCHES_SEEN; - /* Hook the tails of the branches to the closing node. */ - for (br = REGNODE_p(ret); br; br = regnext(br)) { - const U8 op = PL_regkind[OP(br)]; - if (op == BRANCH) { + /* Hook the tails of the branches to the closing node. */ + for (br = REGNODE_p(ret); br; br = regnext(br)) { + const U8 op = PL_regkind[OP(br)]; + if (op == BRANCH) { if (! REGTAIL_STUDY(pRExC_state, REGNODE_OFFSET(NEXTOPER(br)), ender)) @@ -12359,8 +12359,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) if ( OP(NEXTOPER(br)) != NOTHING || regnext(NEXTOPER(br)) != REGNODE_p(ender)) is_nothing= 0; - } - else if (op == BRANCHJ) { + } + else if (op == BRANCHJ) { bool shut_gcc_up = REGTAIL_STUDY(pRExC_state, REGNODE_OFFSET(NEXTOPER(NEXTOPER(br))), ender); @@ -12370,8 +12370,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) || regnext(NEXTOPER(NEXTOPER(br))) != REGNODE_p(ender)) */ is_nothing= 0; - } - } + } + } if (is_nothing) { regnode * ret_as_regnode = REGNODE_p(ret); br= PL_regkind[OP(ret_as_regnode)] != BRANCH @@ -12402,7 +12402,7 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) NEXT_OFF(br)= REGNODE_p(ender) - br; } } - } + } } { @@ -12411,47 +12411,47 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp, U32 depth) static const char parens[] = "=!aA<,>Bbt"; /* flag below is set to 0 up through 'A'; 1 for larger */ - if (paren && (p = strchr(parens, paren))) { - U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH; - int flag = (p - parens) > 3; + if (paren && (p = strchr(parens, paren))) { + U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH; + int flag = (p - parens) > 3; - if (paren == '>' || paren == 't') { - node = SUSPEND, flag = 0; + if (paren == '>' || paren == 't') { + node = SUSPEND, flag = 0; } - reginsert(pRExC_state, node, ret, depth+1); + reginsert(pRExC_state, node, ret, depth+1); Set_Node_Cur_Length(REGNODE_p(ret), parse_start); - Set_Node_Offset(REGNODE_p(ret), parse_start + 1); - FLAGS(REGNODE_p(ret)) = flag; + Set_Node_Offset(REGNODE_p(ret), parse_start + 1); + FLAGS(REGNODE_p(ret)) = flag; if (! REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL))) { REQUIRE_BRANCHJ(flagp, 0); } - } + } } /* Check for proper termination. */ if (paren) { /* restore original flags, but keep (?p) and, if we've encountered * something in the parse that changes /d rules into /u, keep the /u */ - RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY); + RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY); if (DEPENDS_SEMANTICS && toUSE_UNI_CHARSET_NOT_DEPENDS) { set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET); } - if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') { - RExC_parse = oregcomp_parse; - vFAIL("Unmatched ("); - } - nextchar(pRExC_state); + if (RExC_parse >= RExC_end || UCHARAT(RExC_parse) != ')') { + RExC_parse = oregcomp_parse; + vFAIL("Unmatched ("); + } + nextchar(pRExC_state); } else if (!paren && RExC_parse < RExC_end) { - if (*RExC_parse == ')') { - RExC_parse++; - vFAIL("Unmatched )"); - } - else - FAIL("Junk on end of regexp"); /* "Can't happen". */ - NOT_REACHED; /* NOTREACHED */ + if (*RExC_parse == ')') { + RExC_parse++; + vFAIL("Unmatched )"); + } + else + FAIL("Junk on end of regexp"); /* "Can't happen". */ + NOT_REACHED; /* NOTREACHED */ } if (after_freeze > RExC_npar) @@ -12488,12 +12488,12 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) DEBUG_PARSE("brnc"); if (first) - ret = 0; + ret = 0; else { - if (RExC_use_BRANCHJ) - ret = reganode(pRExC_state, BRANCHJ, 0); - else { - ret = reg_node(pRExC_state, BRANCH); + if (RExC_use_BRANCHJ) + ret = reganode(pRExC_state, BRANCHJ, 0); + else { + ret = reg_node(pRExC_state, BRANCH); Set_Node_Length(REGNODE_p(ret), 1); } } @@ -12503,38 +12503,38 @@ S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth) skip_to_be_ignored_text(pRExC_state, &RExC_parse, FALSE /* Don't force to /x */ ); while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') { - flags &= ~TRYAGAIN; + flags &= ~TRYAGAIN; latest = regpiece(pRExC_state, &flags, depth+1); - if (latest == 0) { - if (flags & TRYAGAIN) - continue; + if (latest == 0) { + if (flags & TRYAGAIN) + continue; RETURN_FAIL_ON_RESTART(flags, flagp); FAIL2("panic: regpiece returned failure, flags=%#" UVxf, (UV) flags); - } - else if (ret == 0) + } + else if (ret == 0) ret = latest; - *flagp |= flags&(HASWIDTH|POSTPONED); - if (chain != 0) { - /* FIXME adding one for every branch after the first is probably - * excessive now we have TRIE support. (hv) */ - MARK_NAUGHTY(1); + *flagp |= flags&(HASWIDTH|POSTPONED); + if (chain != 0) { + /* FIXME adding one for every branch after the first is probably + * excessive now we have TRIE support. (hv) */ + MARK_NAUGHTY(1); if (! REGTAIL(pRExC_state, chain, latest)) { /* XXX We could just redo this branch, but figuring out what * bookkeeping needs to be reset is a pain, and it's likely * that other branches that goto END will also be too large */ REQUIRE_BRANCHJ(flagp, 0); } - } - chain = latest; - c++; + } + chain = latest; + c++; } if (chain == 0) { /* Loop ran zero times. */ - chain = reg_node(pRExC_state, NOTHING); - if (ret == 0) - ret = chain; + chain = reg_node(pRExC_state, NOTHING); + if (ret == 0) + ret = chain; } if (c == 1) { - *flagp |= flags&SIMPLE; + *flagp |= flags&SIMPLE; } return ret; @@ -12551,15 +12551,15 @@ Perl_regcurly(const char *s) PERL_ARGS_ASSERT_REGCURLY; if (*s++ != '{') - return FALSE; + return FALSE; if (!isDIGIT(*s)) - return FALSE; + return FALSE; while (isDIGIT(*s)) - s++; + s++; if (*s == ',') { - s++; - while (isDIGIT(*s)) - s++; + s++; + while (isDIGIT(*s)) + s++; } return *s == '}'; @@ -13351,7 +13351,7 @@ S_new_regcurly(const char *s, const char *e) PERL_ARGS_ASSERT_NEW_REGCURLY; if (s >= e || *s++ != '{') - return FALSE; + return FALSE; while (s < e && isSPACE(*s)) { s++; @@ -13365,7 +13365,7 @@ S_new_regcurly(const char *s, const char *e) } if (*s == ',') { - s++; + s++; while (s < e && isSPACE(*s)) { s++; } @@ -13423,36 +13423,36 @@ S_backref_value(char *p, char *e) A summary of the code structure is: switch (first_byte) { - cases for each special: - handle this special; - break; - case '\\': - switch (2nd byte) { - cases for each unambiguous special: - handle this special; - break; - cases for each ambigous special/literal: - disambiguate; - if (special) handle here - else goto defchar; - default: // unambiguously literal: - goto defchar; - } - default: // is a literal char - // FALL THROUGH - defchar: - create EXACTish node for literal; - while (more input and node isn't full) { - switch (input_byte) { - cases for each special; + cases for each special: + handle this special; + break; + case '\\': + switch (2nd byte) { + cases for each unambiguous special: + handle this special; + break; + cases for each ambigous special/literal: + disambiguate; + if (special) handle here + else goto defchar; + default: // unambiguously literal: + goto defchar; + } + default: // is a literal char + // FALL THROUGH + defchar: + create EXACTish node for literal; + while (more input and node isn't full) { + switch (input_byte) { + cases for each special; make sure parse pointer is set so that the next call to regatom will see this special first goto loopdone; // EXACTish node terminated by prev. char - default: - append char to EXACTISH node; - } - get next input byte; - } + default: + append char to EXACTISH node; + } + get next input byte; + } loopdone: } return the generated node; @@ -13486,37 +13486,37 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) assert(RExC_parse < RExC_end); switch ((U8)*RExC_parse) { case '^': - RExC_seen_zerolen++; - nextchar(pRExC_state); - if (RExC_flags & RXf_PMf_MULTILINE) - ret = reg_node(pRExC_state, MBOL); - else - ret = reg_node(pRExC_state, SBOL); + RExC_seen_zerolen++; + nextchar(pRExC_state); + if (RExC_flags & RXf_PMf_MULTILINE) + ret = reg_node(pRExC_state, MBOL); + else + ret = reg_node(pRExC_state, SBOL); Set_Node_Length(REGNODE_p(ret), 1); /* MJD */ - break; + break; case '$': - nextchar(pRExC_state); - if (*RExC_parse) - RExC_seen_zerolen++; - if (RExC_flags & RXf_PMf_MULTILINE) - ret = reg_node(pRExC_state, MEOL); - else - ret = reg_node(pRExC_state, SEOL); + nextchar(pRExC_state); + if (*RExC_parse) + RExC_seen_zerolen++; + if (RExC_flags & RXf_PMf_MULTILINE) + ret = reg_node(pRExC_state, MEOL); + else + ret = reg_node(pRExC_state, SEOL); Set_Node_Length(REGNODE_p(ret), 1); /* MJD */ - break; + break; case '.': - nextchar(pRExC_state); - if (RExC_flags & RXf_PMf_SINGLELINE) - ret = reg_node(pRExC_state, SANY); - else - ret = reg_node(pRExC_state, REG_ANY); - *flagp |= HASWIDTH|SIMPLE; - MARK_NAUGHTY(1); + nextchar(pRExC_state); + if (RExC_flags & RXf_PMf_SINGLELINE) + ret = reg_node(pRExC_state, SANY); + else + ret = reg_node(pRExC_state, REG_ANY); + *flagp |= HASWIDTH|SIMPLE; + MARK_NAUGHTY(1); Set_Node_Length(REGNODE_p(ret), 1); /* MJD */ - break; + break; case '[': { - char * const oregcomp_parse = ++RExC_parse; + char * const oregcomp_parse = ++RExC_parse; ret = regclass(pRExC_state, flagp, depth+1, FALSE, /* means parse the whole char class */ TRUE, /* allow multi-char folds */ @@ -13529,65 +13529,65 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) FAIL2("panic: regclass returned failure to regatom, flags=%#" UVxf, (UV) *flagp); } - if (*RExC_parse != ']') { - RExC_parse = oregcomp_parse; - vFAIL("Unmatched ["); - } - nextchar(pRExC_state); + if (*RExC_parse != ']') { + RExC_parse = oregcomp_parse; + vFAIL("Unmatched ["); + } + nextchar(pRExC_state); Set_Node_Length(REGNODE_p(ret), RExC_parse - oregcomp_parse + 1); /* MJD */ - break; + break; } case '(': - nextchar(pRExC_state); + nextchar(pRExC_state); ret = reg(pRExC_state, 2, &flags, depth+1); - if (ret == 0) { - if (flags & TRYAGAIN) { - if (RExC_parse >= RExC_end) { - /* Make parent create an empty node if needed. */ - *flagp |= TRYAGAIN; - return(0); - } - goto tryagain; - } + if (ret == 0) { + if (flags & TRYAGAIN) { + if (RExC_parse >= RExC_end) { + /* Make parent create an empty node if needed. */ + *flagp |= TRYAGAIN; + return(0); + } + goto tryagain; + } RETURN_FAIL_ON_RESTART(flags, flagp); FAIL2("panic: reg returned failure to regatom, flags=%#" UVxf, (UV) flags); - } - *flagp |= flags&(HASWIDTH|SIMPLE|POSTPONED); - break; + } + *flagp |= flags&(HASWIDTH|SIMPLE|POSTPONED); + break; case '|': case ')': - if (flags & TRYAGAIN) { - *flagp |= TRYAGAIN; - return 0; - } - vFAIL("Internal urp"); - /* Supposed to be caught earlier. */ - break; + if (flags & TRYAGAIN) { + *flagp |= TRYAGAIN; + return 0; + } + vFAIL("Internal urp"); + /* Supposed to be caught earlier. */ + break; case '?': case '+': case '*': - RExC_parse++; - vFAIL("Quantifier follows nothing"); - break; + RExC_parse++; + vFAIL("Quantifier follows nothing"); + break; case '\\': - /* Special Escapes - - This switch handles escape sequences that resolve to some kind - of special regop and not to literal text. Escape sequences that - resolve to literal text are handled below in the switch marked - "Literal Escapes". - - Every entry in this switch *must* have a corresponding entry - in the literal escape switch. However, the opposite is not - required, as the default for this switch is to jump to the - literal text handling code. - */ - RExC_parse++; - switch ((U8)*RExC_parse) { - /* Special Escapes */ - case 'A': - RExC_seen_zerolen++; + /* Special Escapes + + This switch handles escape sequences that resolve to some kind + of special regop and not to literal text. Escape sequences that + resolve to literal text are handled below in the switch marked + "Literal Escapes". + + Every entry in this switch *must* have a corresponding entry + in the literal escape switch. However, the opposite is not + required, as the default for this switch is to jump to the + literal text handling code. + */ + RExC_parse++; + switch ((U8)*RExC_parse) { + /* Special Escapes */ + case 'A': + RExC_seen_zerolen++; /* Under wildcards, this is changed to match \n; should be * invisible to the user, as they have to compile under /m */ if (RExC_pm_flags & PMf_WILDCARD) { @@ -13599,8 +13599,8 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * /\A/ from /^/ in split. */ FLAGS(REGNODE_p(ret)) = 1; } - goto finish_meta_pat; - case 'G': + goto finish_meta_pat; + case 'G': if (RExC_pm_flags & PMf_WILDCARD) { RExC_parse++; /* diag_listed_as: Use of %s is not allowed in Unicode property @@ -13609,10 +13609,10 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) vFAIL("Use of '\\G' is not allowed in Unicode property" " wildcard subpatterns"); } - ret = reg_node(pRExC_state, GPOS); + ret = reg_node(pRExC_state, GPOS); RExC_seen |= REG_GPOS_SEEN; - goto finish_meta_pat; - case 'K': + goto finish_meta_pat; + case 'K': if (!RExC_in_lookaround) { RExC_seen_zerolen++; ret = reg_node(pRExC_state, KEEPS); @@ -13627,7 +13627,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) ++RExC_parse; /* advance past the 'K' */ vFAIL("\\K not permitted in lookahead/lookbehind"); } - case 'Z': + case 'Z': if (RExC_pm_flags & PMf_WILDCARD) { /* See comment under \A above */ ret = reg_node(pRExC_state, MEOL); @@ -13635,9 +13635,9 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) else { ret = reg_node(pRExC_state, SEOL); } - RExC_seen_zerolen++; /* Do not optimize RE away */ - goto finish_meta_pat; - case 'z': + RExC_seen_zerolen++; /* Do not optimize RE away */ + goto finish_meta_pat; + case 'z': if (RExC_pm_flags & PMf_WILDCARD) { /* See comment under \A above */ ret = reg_node(pRExC_state, MEOL); @@ -13645,28 +13645,28 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) else { ret = reg_node(pRExC_state, EOS); } - RExC_seen_zerolen++; /* Do not optimize RE away */ - goto finish_meta_pat; - case 'C': - vFAIL("\\C no longer supported"); - case 'X': - ret = reg_node(pRExC_state, CLUMP); - *flagp |= HASWIDTH; - goto finish_meta_pat; + RExC_seen_zerolen++; /* Do not optimize RE away */ + goto finish_meta_pat; + case 'C': + vFAIL("\\C no longer supported"); + case 'X': + ret = reg_node(pRExC_state, CLUMP); + *flagp |= HASWIDTH; + goto finish_meta_pat; - case 'B': + case 'B': invert = 1; /* FALLTHROUGH */ - case 'b': + case 'b': { U8 flags = 0; - regex_charset charset = get_regex_charset(RExC_flags); + regex_charset charset = get_regex_charset(RExC_flags); - RExC_seen_zerolen++; + RExC_seen_zerolen++; RExC_seen |= REG_LOOKBEHIND_SEEN; - op = BOUND + charset; + op = BOUND + charset; - if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') { + if (RExC_parse >= RExC_end || *(RExC_parse + 1) != '{') { flags = TRADITIONAL_BOUND; if (op > BOUNDA) { /* /aa is same as /a */ op = BOUNDA; @@ -13726,9 +13726,9 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) default: bad_bound_type: RExC_parse = endbrace; - vFAIL2utf8f( + vFAIL2utf8f( "'%" UTF8f "' is an unknown bound type", - UTF8fARG(UTF, length, endbrace - length)); + UTF8fARG(UTF, length, endbrace - length)); NOT_REACHED; /*NOTREACHED*/ } RExC_parse = endbrace; @@ -13751,7 +13751,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) ? ASCII_RESTRICT_PAT_MODS : ASCII_MORE_RESTRICT_PAT_MODS); } - } + } if (op == BOUND) { RExC_seen_d_op = TRUE; @@ -13764,29 +13764,29 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) op += NBOUND - BOUND; } - ret = reg_node(pRExC_state, op); + ret = reg_node(pRExC_state, op); FLAGS(REGNODE_p(ret)) = flags; - goto finish_meta_pat; + goto finish_meta_pat; } - case 'R': - ret = reg_node(pRExC_state, LNBREAK); - *flagp |= HASWIDTH|SIMPLE; - goto finish_meta_pat; - - case 'd': - case 'D': - case 'h': - case 'H': - case 'p': - case 'P': - case 's': - case 'S': - case 'v': - case 'V': - case 'w': - case 'W': + case 'R': + ret = reg_node(pRExC_state, LNBREAK); + *flagp |= HASWIDTH|SIMPLE; + goto finish_meta_pat; + + case 'd': + case 'D': + case 'h': + case 'H': + case 'p': + case 'P': + case 's': + case 'S': + case 'v': + case 'V': + case 'w': + case 'W': /* These all have the same meaning inside [brackets], and it knows * how to do the best optimizations for them. So, pretend we found * these within brackets, and let it do the work */ @@ -13824,7 +13824,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) Set_Node_Offset(REGNODE_p(ret), parse_start); Set_Node_Length(REGNODE_p(ret), RExC_parse - parse_start + 1); /* MJD */ nextchar(pRExC_state); - break; + break; case 'N': /* Handle \N, \N{} and \N{NAMED SEQUENCE} (the latter meaning the * \N{...} evaluates to a sequence of more than one code points). @@ -13857,7 +13857,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) RExC_parse = parse_start; goto defchar; - case 'k': /* Handle \k<NAME> and \k'NAME' */ + case 'k': /* Handle \k<NAME> and \k'NAME' */ parse_named_seq: { char ch; @@ -13866,11 +13866,11 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) && ch != '\'' && ch != '{')) { - RExC_parse++; - /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */ - vFAIL2("Sequence %.2s... not terminated", parse_start); - } else { - RExC_parse += 2; + RExC_parse++; + /* diag_listed_as: Sequence \%s... not terminated in regex; marked by <-- HERE in m/%s/ */ + vFAIL2("Sequence %.2s... not terminated", parse_start); + } else { + RExC_parse += 2; ret = handle_named_backref(pRExC_state, flagp, parse_start, @@ -13881,30 +13881,30 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) : '\''); } break; - } - case 'g': - case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - { - I32 num; - bool hasbrace = 0; - - if (*RExC_parse == 'g') { + } + case 'g': + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + { + I32 num; + bool hasbrace = 0; + + if (*RExC_parse == 'g') { bool isrel = 0; - RExC_parse++; - if (*RExC_parse == '{') { - RExC_parse++; - hasbrace = 1; - } - if (*RExC_parse == '-') { - RExC_parse++; - isrel = 1; - } - if (hasbrace && !isDIGIT(*RExC_parse)) { - if (isrel) RExC_parse--; + RExC_parse++; + if (*RExC_parse == '{') { + RExC_parse++; + hasbrace = 1; + } + if (*RExC_parse == '-') { + RExC_parse++; + isrel = 1; + } + if (hasbrace && !isDIGIT(*RExC_parse)) { + if (isrel) RExC_parse--; RExC_parse -= 2; - goto parse_named_seq; + goto parse_named_seq; } if (RExC_parse >= RExC_end) { @@ -13915,7 +13915,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) vFAIL("Reference to invalid group 0"); else if (num == I32_MAX) { if (isDIGIT(*RExC_parse)) - vFAIL("Reference to nonexistent group"); + vFAIL("Reference to nonexistent group"); else unterminated_g: vFAIL("Unterminated \\g... pattern"); @@ -14001,48 +14001,48 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) Set_Node_Cur_Length(REGNODE_p(ret), parse_start-1); skip_to_be_ignored_text(pRExC_state, &RExC_parse, FALSE /* Don't force to /x */ ); - } - break; - case '\0': - if (RExC_parse >= RExC_end) - FAIL("Trailing \\"); - /* FALLTHROUGH */ - default: - /* Do not generate "unrecognized" warnings here, we fall - back into the quick-grab loop below */ + } + break; + case '\0': + if (RExC_parse >= RExC_end) + FAIL("Trailing \\"); + /* FALLTHROUGH */ + default: + /* Do not generate "unrecognized" warnings here, we fall + back into the quick-grab loop below */ RExC_parse = parse_start; - goto defchar; - } /* end of switch on a \foo sequence */ - break; + goto defchar; + } /* end of switch on a \foo sequence */ + break; case '#': /* '#' comments should have been spaced over before this function was * called */ assert((RExC_flags & RXf_PMf_EXTENDED) == 0); - /* + /* if (RExC_flags & RXf_PMf_EXTENDED) { - RExC_parse = reg_skipcomment( pRExC_state, RExC_parse ); - if (RExC_parse < RExC_end) - goto tryagain; - } + RExC_parse = reg_skipcomment( pRExC_state, RExC_parse ); + if (RExC_parse < RExC_end) + goto tryagain; + } */ - /* FALLTHROUGH */ + /* FALLTHROUGH */ default: - defchar: { + defchar: { /* Here, we have determined that the next thing is probably a * literal character. RExC_parse points to the first byte of its * definition. (It still may be an escape sequence that evaluates * to a single character) */ - STRLEN len = 0; - UV ender = 0; - char *p; - char *s, *old_s = NULL, *old_old_s = NULL; - char *s0; + STRLEN len = 0; + UV ender = 0; + char *p; + char *s, *old_s = NULL, *old_old_s = NULL; + char *s0; U32 max_string_len = 255; /* We may have to reparse the node, artificially stopping filling @@ -14116,11 +14116,11 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) FILL_NODE(ret, node_type); RExC_emit++; - s = STRING(REGNODE_p(ret)); + s = STRING(REGNODE_p(ret)); s0 = s; - reparse: + reparse: p = RExC_parse; len = 0; @@ -14162,7 +14162,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * The exceptions override this */ Size_t added_len = 1; - oldp = p; + oldp = p; old_old_s = old_s; old_s = s; @@ -14170,62 +14170,62 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) assert( (RExC_flags & RXf_PMf_EXTENDED) == 0 || ! is_PATWS_safe((p), RExC_end, UTF)); - switch ((U8)*p) { + switch ((U8)*p) { const char* message; U32 packed_warn; U8 grok_c_char; - case '^': - case '$': - case '.': - case '[': - case '(': - case ')': - case '|': - goto loopdone; - case '\\': - /* Literal Escapes Switch - - This switch is meant to handle escape sequences that - resolve to a literal character. - - Every escape sequence that represents something - else, like an assertion or a char class, is handled - in the switch marked 'Special Escapes' above in this - routine, but also has an entry here as anything that - isn't explicitly mentioned here will be treated as - an unescaped equivalent literal. - */ - - switch ((U8)*++p) { - - /* These are all the special escapes. */ - case 'A': /* Start assertion */ - case 'b': case 'B': /* Word-boundary assertion*/ - case 'C': /* Single char !DANGEROUS! */ - case 'd': case 'D': /* digit class */ - case 'g': case 'G': /* generic-backref, pos assertion */ - case 'h': case 'H': /* HORIZWS */ - case 'k': case 'K': /* named backref, keep marker */ - case 'p': case 'P': /* Unicode property */ - case 'R': /* LNBREAK */ - case 's': case 'S': /* space class */ - case 'v': case 'V': /* VERTWS */ - case 'w': case 'W': /* word class */ + case '^': + case '$': + case '.': + case '[': + case '(': + case ')': + case '|': + goto loopdone; + case '\\': + /* Literal Escapes Switch + + This switch is meant to handle escape sequences that + resolve to a literal character. + + Every escape sequence that represents something + else, like an assertion or a char class, is handled + in the switch marked 'Special Escapes' above in this + routine, but also has an entry here as anything that + isn't explicitly mentioned here will be treated as + an unescaped equivalent literal. + */ + + switch ((U8)*++p) { + + /* These are all the special escapes. */ + case 'A': /* Start assertion */ + case 'b': case 'B': /* Word-boundary assertion*/ + case 'C': /* Single char !DANGEROUS! */ + case 'd': case 'D': /* digit class */ + case 'g': case 'G': /* generic-backref, pos assertion */ + case 'h': case 'H': /* HORIZWS */ + case 'k': case 'K': /* named backref, keep marker */ + case 'p': case 'P': /* Unicode property */ + case 'R': /* LNBREAK */ + case 's': case 'S': /* space class */ + case 'v': case 'V': /* VERTWS */ + case 'w': case 'W': /* word class */ case 'X': /* eXtended Unicode "combining character sequence" */ - case 'z': case 'Z': /* End of line/string assertion */ - --p; - goto loopdone; - - /* Anything after here is an escape that resolves to a - literal. (Except digits, which may or may not) - */ - case 'n': - ender = '\n'; - p++; - break; - case 'N': /* Handle a single-code point named character. */ + case 'z': case 'Z': /* End of line/string assertion */ + --p; + goto loopdone; + + /* Anything after here is an escape that resolves to a + literal. (Except digits, which may or may not) + */ + case 'n': + ender = '\n'; + p++; + break; + case 'N': /* Handle a single-code point named character. */ RExC_parse = p + 1; if (! grok_bslash_N(pRExC_state, NULL, /* Fail if evaluates to @@ -14269,27 +14269,27 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } break; - case 'r': - ender = '\r'; - p++; - break; - case 't': - ender = '\t'; - p++; - break; - case 'f': - ender = '\f'; - p++; - break; - case 'e': - ender = ESC_NATIVE; - p++; - break; - case 'a': - ender = '\a'; - p++; - break; - case 'o': + case 'r': + ender = '\r'; + p++; + break; + case 't': + ender = '\t'; + p++; + break; + case 'f': + ender = '\f'; + p++; + break; + case 'e': + ender = ESC_NATIVE; + p++; + break; + case 'a': + ender = '\a'; + p++; + break; + case 'o': if (! grok_bslash_o(&p, RExC_end, &ender, @@ -14308,7 +14308,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) warn_non_literal_string(p, packed_warn, message); } break; - case 'x': + case 'x': if (! grok_bslash_x(&p, RExC_end, &ender, @@ -14335,7 +14335,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } #endif break; - case 'c': + case 'c': p++; if (! grok_bslash_c(*p, &grok_c_char, &message, &packed_warn)) @@ -14354,7 +14354,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) warn_non_literal_string(p, packed_warn, message); } - break; + break; case '8': case '9': /* must be a backreference */ --p; /* we have an escape like \8 which cannot be an octal escape @@ -14362,7 +14362,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * escape which may or may not be a legitimate backref. */ goto loopdone; case '1': case '2': case '3':case '4': - case '5': case '6': case '7': + case '5': case '6': case '7': /* When we parse backslash escapes there is ambiguity * between backreferences and octal escapes. Any escape * from \1 - \9 is a backreference, any multi-digit @@ -14387,29 +14387,29 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } /* FALLTHROUGH */ case '0': - { - I32 flags = PERL_SCAN_SILENT_ILLDIGIT + { + I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_NOTIFY_ILLDIGIT; - STRLEN numlen = 3; - ender = grok_oct(p, &numlen, &flags, NULL); - p += numlen; + STRLEN numlen = 3; + ender = grok_oct(p, &numlen, &flags, NULL); + p += numlen; if ( (flags & PERL_SCAN_NOTIFY_ILLDIGIT) && isDIGIT(*p) /* like \08, \178 */ && ckWARN(WARN_REGEXP)) { - reg_warn_non_literal_string( + reg_warn_non_literal_string( p + 1, form_alien_digit_msg(8, numlen, p, RExC_end, UTF, FALSE)); } - } - break; - case '\0': - if (p >= RExC_end) - FAIL("Trailing \\"); - /* FALLTHROUGH */ - default: - if (isALPHANUMERIC(*p)) { + } + break; + case '\0': + if (p >= RExC_end) + FAIL("Trailing \\"); + /* FALLTHROUGH */ + default: + if (isALPHANUMERIC(*p)) { /* An alpha followed by '{' is going to fail next * iteration, so don't output this warning in that * case */ @@ -14417,11 +14417,11 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) ckWARN2reg(p + 1, "Unrecognized escape \\%.1s" " passed through", p); } - } - goto normal_default; - } /* End of switch on '\' */ - break; - case '{': + } + goto normal_default; + } /* End of switch on '\' */ + break; + case '{': /* Trying to gain new uses for '{' without breaking too * much existing code is hard. The solution currently * adopted is: @@ -14437,7 +14437,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * misspelled the quantifier. Without this warning, * the quantifier would silently be taken as a literal * string of characters instead of a meta construct */ - if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) { + if (len || (p > RExC_start && isALPHA_A(*(p - 1)))) { if ( RExC_strict || ( p > parse_start + 1 && isALPHA_A(*(p - 1)) @@ -14450,28 +14450,28 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) } ckWARNreg(p + 1, "Unescaped left brace in regex is" " passed through"); - } - goto normal_default; + } + goto normal_default; case '}': case ']': if (p > RExC_parse && RExC_strict) { ckWARN2reg(p + 1, "Unescaped literal '%c'", *p); } - /*FALLTHROUGH*/ - default: /* A literal character */ - normal_default: - if (! UTF8_IS_INVARIANT(*p) && UTF) { - STRLEN numlen; - ender = utf8n_to_uvchr((U8*)p, RExC_end - p, - &numlen, UTF8_ALLOW_DEFAULT); - p += numlen; - } - else - ender = (U8) *p++; - break; - } /* End of switch on the literal */ - - /* Here, have looked at the literal character, and <ender> + /*FALLTHROUGH*/ + default: /* A literal character */ + normal_default: + if (! UTF8_IS_INVARIANT(*p) && UTF) { + STRLEN numlen; + ender = utf8n_to_uvchr((U8*)p, RExC_end - p, + &numlen, UTF8_ALLOW_DEFAULT); + p += numlen; + } + else + ender = (U8) *p++; + break; + } /* End of switch on the literal */ + + /* Here, have looked at the literal character, and <ender> * contains its ordinal; <p> points to the character after it. * */ @@ -14733,20 +14733,20 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) * requires UTF-8 to represent. */ : (char) toLOWER_L1(ender); } - } /* End of adding current character to the node */ + } /* End of adding current character to the node */ done_with_this_char: len += added_len; - if (next_is_quantifier) { + if (next_is_quantifier) { /* Here, the next input is a quantifier, and to get here, * the current character is the only one in the node. */ goto loopdone; - } + } - } /* End of loop through literal characters */ + } /* End of loop through literal characters */ /* Here we have either exhausted the input or run out of room in * the node. If the former, we are done. (If we encountered a @@ -15236,7 +15236,7 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) Safefree(locfold_buf); Safefree(loc_correspondence); } - } /* End of verifying node ends with an appropriate char */ + } /* End of verifying node ends with an appropriate char */ /* We need to start the next node at the character that didn't fit * in this one */ @@ -15360,15 +15360,15 @@ S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) Set_Node_Length(REGNODE_p(ret), p - parse_start - 1); RExC_parse = p; - { - /* len is STRLEN which is unsigned, need to copy to signed */ - IV iv = len; - if (iv < 0) - vFAIL("Internal disaster"); - } + { + /* len is STRLEN which is unsigned, need to copy to signed */ + IV iv = len; + if (iv < 0) + vFAIL("Internal disaster"); + } - } /* End of label 'defchar:' */ - break; + } /* End of label 'defchar:' */ + break; } /* End of giant switch on input character */ /* Position parse to next real character */ @@ -15408,53 +15408,53 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) ANYOF_BITMAP_ZERO(node); if (*invlist_ptr) { - /* This gets set if we actually need to modify things */ - bool change_invlist = FALSE; + /* This gets set if we actually need to modify things */ + bool change_invlist = FALSE; - UV start, end; + UV start, end; - /* Start looking through *invlist_ptr */ - invlist_iterinit(*invlist_ptr); - while (invlist_iternext(*invlist_ptr, &start, &end)) { - UV high; - int i; + /* Start looking through *invlist_ptr */ + invlist_iterinit(*invlist_ptr); + while (invlist_iternext(*invlist_ptr, &start, &end)) { + UV high; + int i; if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) { ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP; } - /* Quit if are above what we should change */ - if (start >= NUM_ANYOF_CODE_POINTS) { - break; - } + /* Quit if are above what we should change */ + if (start >= NUM_ANYOF_CODE_POINTS) { + break; + } - change_invlist = TRUE; + change_invlist = TRUE; - /* Set all the bits in the range, up to the max that we are doing */ - high = (end < NUM_ANYOF_CODE_POINTS - 1) + /* Set all the bits in the range, up to the max that we are doing */ + high = (end < NUM_ANYOF_CODE_POINTS - 1) ? end : NUM_ANYOF_CODE_POINTS - 1; - for (i = start; i <= (int) high; i++) { + for (i = start; i <= (int) high; i++) { ANYOF_BITMAP_SET(node, i); - } - } - invlist_iterfinish(*invlist_ptr); + } + } + invlist_iterfinish(*invlist_ptr); /* Done with loop; remove any code points that are in the bitmap from * *invlist_ptr; similarly for code points above the bitmap if we have * a flag to match all of them anyways */ - if (change_invlist) { - _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr); - } + if (change_invlist) { + _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr); + } if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) { - _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr); - } + _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr); + } - /* If have completely emptied it, remove it completely */ - if (_invlist_len(*invlist_ptr) == 0) { - SvREFCNT_dec_NN(*invlist_ptr); - *invlist_ptr = NULL; - } + /* If have completely emptied it, remove it completely */ + if (_invlist_len(*invlist_ptr) == 0) { + SvREFCNT_dec_NN(*invlist_ptr); + *invlist_ptr = NULL; + } } } @@ -16495,7 +16495,7 @@ redo_curchar: RExC_parse++; RExC_sets_depth++; - node = reg(pRExC_state, 2, flagp, depth+1); + node = reg(pRExC_state, 2, flagp, depth+1); RETURN_FAIL_ON_RESTART(*flagp, flagp); if ( OP(REGNODE_p(node)) != REGEX_SET @@ -17316,7 +17316,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, SV *listsv = NULL; /* List of \p{user-defined} whose definitions aren't available at the time this was called */ STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more - than just initialized. */ + than just initialized. */ SV* properties = NULL; /* Code points that match \p{} \P{} */ SV* posixes = NULL; /* Code points that match classes like [:word:], extended beyond the Latin1 range. These have to @@ -17333,7 +17333,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, leading to less compilation and execution work */ UV element_count = 0; /* Number of distinct elements in the class. - Optimizations may be possible if this is tiny */ + Optimizations may be possible if this is tiny */ AV * multi_char_matches = NULL; /* Code points that fold to more than one character; used under /i */ UV n; @@ -17436,7 +17436,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, assert(RExC_parse <= RExC_end); if (UCHARAT(RExC_parse) == '^') { /* Complement the class */ - RExC_parse++; + RExC_parse++; invert = TRUE; allow_mutiple_chars = FALSE; MARK_NAUGHTY(1); @@ -17471,7 +17471,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, /* allow 1st char to be ']' (allowing it to be '-' is dealt with later) */ if (UCHARAT(RExC_parse) == ']') - goto charclassloop; + goto charclassloop; while (1) { @@ -17499,23 +17499,23 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, charclassloop: - namedclass = OOB_NAMEDCLASS; /* initialize as illegal */ + namedclass = OOB_NAMEDCLASS; /* initialize as illegal */ save_value = value; save_prevvalue = prevvalue; - if (!range) { - rangebegin = RExC_parse; - element_count++; + if (!range) { + rangebegin = RExC_parse; + element_count++; non_portable_endpoint = 0; - } - if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) { - value = utf8n_to_uvchr((U8*)RExC_parse, - RExC_end - RExC_parse, - &numlen, UTF8_ALLOW_DEFAULT); - RExC_parse += numlen; - } - else - value = UCHARAT(RExC_parse++); + } + if (UTF && ! UTF8_IS_INVARIANT(* RExC_parse)) { + value = utf8n_to_uvchr((U8*)RExC_parse, + RExC_end - RExC_parse, + &numlen, UTF8_ALLOW_DEFAULT); + RExC_parse += numlen; + } + else + value = UCHARAT(RExC_parse++); if (value == '[') { char * posix_class_end; @@ -17570,20 +17570,20 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, vFAIL("Unmatched ["); } - if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) { - value = utf8n_to_uvchr((U8*)RExC_parse, - RExC_end - RExC_parse, - &numlen, UTF8_ALLOW_DEFAULT); - RExC_parse += numlen; - } - else - value = UCHARAT(RExC_parse++); + if (UTF && ! UTF8_IS_INVARIANT(UCHARAT(RExC_parse))) { + value = utf8n_to_uvchr((U8*)RExC_parse, + RExC_end - RExC_parse, + &numlen, UTF8_ALLOW_DEFAULT); + RExC_parse += numlen; + } + else + value = UCHARAT(RExC_parse++); - /* Some compilers cannot handle switching on 64-bit integer - * values, therefore value cannot be an UV. Yes, this will - * be a problem later if we want switch on Unicode. - * A similar issue a little bit later when switching on - * namedclass. --jhi */ + /* Some compilers cannot handle switching on 64-bit integer + * values, therefore value cannot be an UV. Yes, this will + * be a problem later if we want switch on Unicode. + * A similar issue a little bit later when switching on + * namedclass. --jhi */ /* If the \ is escaping white space when white space is being * skipped, it means that that white space is wanted literally, and @@ -17594,16 +17594,16 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, U32 packed_warn; U8 grok_c_char; - case 'w': namedclass = ANYOF_WORDCHAR; break; - case 'W': namedclass = ANYOF_NWORDCHAR; break; - case 's': namedclass = ANYOF_SPACE; break; - case 'S': namedclass = ANYOF_NSPACE; break; - case 'd': namedclass = ANYOF_DIGIT; break; - case 'D': namedclass = ANYOF_NDIGIT; break; - case 'v': namedclass = ANYOF_VERTWS; break; - case 'V': namedclass = ANYOF_NVERTWS; break; - case 'h': namedclass = ANYOF_HORIZWS; break; - case 'H': namedclass = ANYOF_NHORIZWS; break; + case 'w': namedclass = ANYOF_WORDCHAR; break; + case 'W': namedclass = ANYOF_NWORDCHAR; break; + case 's': namedclass = ANYOF_SPACE; break; + case 'S': namedclass = ANYOF_NSPACE; break; + case 'd': namedclass = ANYOF_DIGIT; break; + case 'D': namedclass = ANYOF_NDIGIT; break; + case 'v': namedclass = ANYOF_VERTWS; break; + case 'V': namedclass = ANYOF_NVERTWS; break; + case 'h': namedclass = ANYOF_HORIZWS; break; + case 'H': namedclass = ANYOF_NHORIZWS; break; case 'N': /* Handle \N{NAME} in class */ { const char * const backslash_N_beg = RExC_parse - 2; @@ -17670,10 +17670,10 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, unicode_range = TRUE; /* \N{} are Unicode */ } break; - case 'p': - case 'P': - { - char *e; + case 'p': + case 'P': + { + char *e; if (RExC_pm_flags & PMf_WILDCARD) { RExC_parse++; @@ -17684,14 +17684,14 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, " wildcard subpatterns", (char) value, *(RExC_parse - 1)); } - /* \p means they want Unicode semantics */ - REQUIRE_UNI_RULES(flagp, 0); + /* \p means they want Unicode semantics */ + REQUIRE_UNI_RULES(flagp, 0); - if (RExC_parse >= RExC_end) - vFAIL2("Empty \\%c", (U8)value); - if (*RExC_parse == '{') { - const U8 c = (U8)value; - e = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse); + if (RExC_parse >= RExC_end) + vFAIL2("Empty \\%c", (U8)value); + if (*RExC_parse == '{') { + const U8 c = (U8)value; + e = (char *) memchr(RExC_parse, '}', RExC_end - RExC_parse); if (!e) { RExC_parse++; vFAIL2("Missing right brace on \\%c{}", c); @@ -17703,9 +17703,9 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * any '^', even when not under /x */ while (isSPACE(*RExC_parse)) { RExC_parse++; - } + } - if (UCHARAT(RExC_parse) == '^') { + if (UCHARAT(RExC_parse) == '^') { /* toggle. (The rhs xor gets the single bit that * differs between P and p; the other xor inverts just @@ -17721,12 +17721,12 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, if (e == RExC_parse) vFAIL2("Empty \\%c{}", c); - n = e - RExC_parse; - while (isSPACE(*(RExC_parse + n - 1))) - n--; + n = e - RExC_parse; + while (isSPACE(*(RExC_parse + n - 1))) + n--; - } /* The \p isn't immediately followed by a '{' */ - else if (! isALPHA(*RExC_parse)) { + } /* The \p isn't immediately followed by a '{' */ + else if (! isALPHA(*RExC_parse)) { RExC_parse += (UTF) ? UTF8_SAFE_SKIP(RExC_parse, RExC_end) : 1; @@ -17735,10 +17735,10 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, (U8) value); } else { - e = RExC_parse; - n = 1; - } - { + e = RExC_parse; + n = 1; + } + { char* name = RExC_parse; /* Any message returned about expanding the definition */ @@ -17771,7 +17771,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, mojibake */ RExC_utf8 = TRUE; } - /* diag_listed_as: Can't find Unicode property definition "%s" in regex; marked by <-- HERE in m/%s/ */ + /* diag_listed_as: Can't find Unicode property definition "%s" in regex; marked by <-- HERE in m/%s/ */ vFAIL2utf8f("%" UTF8f, UTF8fARG(SvUTF8(msg), SvCUR(msg), SvPVX(msg))); } @@ -17889,30 +17889,30 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, /* Invert if asking for the complement */ if (value == 'P') { - _invlist_union_complement_2nd(properties, + _invlist_union_complement_2nd(properties, prop_definition, &properties); } else { _invlist_union(properties, prop_definition, &properties); - } + } } } - RExC_parse = e + 1; + RExC_parse = e + 1; namedclass = ANYOF_UNIPROP; /* no official name, but it's named */ - } - break; - case 'n': value = '\n'; break; - case 'r': value = '\r'; break; - case 't': value = '\t'; break; - case 'f': value = '\f'; break; - case 'b': value = '\b'; break; - case 'e': value = ESC_NATIVE; break; - case 'a': value = '\a'; break; - case 'o': - RExC_parse--; /* function expects to be pointed at the 'o' */ + } + break; + case 'n': value = '\n'; break; + case 'r': value = '\r'; break; + case 't': value = '\t'; break; + case 'f': value = '\f'; break; + case 'b': value = '\b'; break; + case 'e': value = ESC_NATIVE; break; + case 'a': value = '\a'; break; + case 'o': + RExC_parse--; /* function expects to be pointed at the 'o' */ if (! grok_bslash_o(&RExC_parse, RExC_end, &value, @@ -17932,9 +17932,9 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, if (value < 256) { non_portable_endpoint++; } - break; - case 'x': - RExC_parse--; /* function expects to be pointed at the 'x' */ + break; + case 'x': + RExC_parse--; /* function expects to be pointed at the 'x' */ if (! grok_bslash_x(&RExC_parse, RExC_end, &value, @@ -17954,8 +17954,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, if (value < 256) { non_portable_endpoint++; } - break; - case 'c': + break; + case 'c': if (! grok_bslash_c(*RExC_parse, &grok_c_char, &message, &packed_warn)) { @@ -17974,16 +17974,16 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, } non_portable_endpoint++; - break; - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': - { - /* Take 1-3 octal digits */ - I32 flags = PERL_SCAN_SILENT_ILLDIGIT + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + { + /* Take 1-3 octal digits */ + I32 flags = PERL_SCAN_SILENT_ILLDIGIT | PERL_SCAN_NOTIFY_ILLDIGIT; numlen = (strict) ? 4 : 3; value = grok_oct(--RExC_parse, &numlen, &flags, NULL); - RExC_parse += numlen; + RExC_parse += numlen; if (numlen != 3) { if (strict) { RExC_parse += (UTF) @@ -18005,11 +18005,11 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, if (value < 256) { non_portable_endpoint++; } - break; - } - default: - /* Allow \_ to not give an error */ - if (isWORDCHAR(value) && value != '_') { + break; + } + default: + /* Allow \_ to not give an error */ + if (isWORDCHAR(value) && value != '_') { if (strict) { vFAIL2("Unrecognized escape \\%c in character class", (int)value); @@ -18019,20 +18019,20 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, "Unrecognized escape \\%c in character class passed through", (int)value); } - } - break; - } /* End of switch on char following backslash */ - } /* end of handling backslash escape sequences */ + } + break; + } /* End of switch on char following backslash */ + } /* end of handling backslash escape sequences */ /* Here, we have the current token in 'value' */ - if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */ + if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */ U8 classnum; - /* a bad range like a-\d, a-[:digit:]. The '-' is taken as a - * literal, as is the character that began the false range, i.e. - * the 'a' in the examples */ - if (range) { + /* a bad range like a-\d, a-[:digit:]. The '-' is taken as a + * literal, as is the character that began the false range, i.e. + * the 'a' in the examples */ + if (range) { const int w = (RExC_parse >= rangebegin) ? RExC_parse - rangebegin : 0; @@ -18050,13 +18050,13 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, prevvalue); } - range = 0; /* this was not a true range */ + range = 0; /* this was not a true range */ element_count += 2; /* So counts for three values */ - } + } classnum = namedclass_to_classnum(namedclass); - if (LOC && namedclass < ANYOF_POSIXL_MAX + if (LOC && namedclass < ANYOF_POSIXL_MAX #ifndef HAS_ISASCII && classnum != _CC_ASCII #endif @@ -18178,8 +18178,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, namedclass % 2 != 0, posixes_ptr); } - } - } /* end of namedclass \blah */ + } + } /* end of namedclass \blah */ SKIP_BRACKETED_WHITE_SPACE(skip_white, RExC_parse, RExC_end); @@ -18192,20 +18192,20 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * the next real character to be processed is the range indicator--the * minus sign */ - if (range) { + if (range) { #ifdef EBCDIC /* For unicode ranges, we have to test that the Unicode as opposed * to the native values are not decreasing. (Above 255, there is * no difference between native and Unicode) */ - if (unicode_range && prevvalue < 255 && value < 255) { + if (unicode_range && prevvalue < 255 && value < 255) { if (NATIVE_TO_LATIN1(prevvalue) > NATIVE_TO_LATIN1(value)) { goto backwards_range; } } else #endif - if (prevvalue > value) /* b-a */ { - int w; + if (prevvalue > value) /* b-a */ { + int w; #ifdef EBCDIC backwards_range: #endif @@ -18214,9 +18214,9 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, "Invalid [] range \"%" UTF8f "\"", UTF8fARG(UTF, w, rangebegin)); NOT_REACHED; /* NOTREACHED */ - } - } - else { + } + } + else { prevvalue = value; /* save the beginning of the potential range */ if (! stop_at_1 /* Can't be a range if parsing just one thing */ && *RExC_parse == '-') @@ -18253,8 +18253,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, range = 1; /* yeah, it's a range! */ continue; /* but do it the next time */ } - } - } + } + } if (namedclass > OOB_NAMEDCLASS) { continue; @@ -18264,8 +18264,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * <prevvalue> is the beginning of the range, if any; or <value> if * not. */ - /* non-Latin1 code point implies unicode semantics. */ - if (value > 255) { + /* non-Latin1 code point implies unicode semantics. */ + if (value > 255) { if (value > MAX_LEGAL_CP && ( value != UV_MAX || prevvalue > MAX_LEGAL_CP)) { @@ -18281,7 +18281,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, PL_extended_cp_format, value); } - } + } /* Ready to process either the single value, or the completed range. * For single-valued non-inverted ranges, we consider the possibility @@ -18518,7 +18518,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, } #endif - range = 0; /* this range (if it was one) is done now */ + range = 0; /* this range (if it was one) is done now */ } /* End of loop through all the text within the brackets */ if ( posix_warnings && av_tindex_skip_len_mg(posix_warnings) >= 0) { @@ -18529,12 +18529,12 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * deal with them by building up a substitute parse string, and recursively * calling reg() on it, instead of proceeding */ if (multi_char_matches) { - SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP); + SV * substitute_parse = newSVpvn_flags("?:", 2, SVs_TEMP); I32 cp_count; - STRLEN len; - char *save_end = RExC_end; - char *save_parse = RExC_parse; - char *save_start = RExC_start; + STRLEN len; + char *save_end = RExC_end; + char *save_parse = RExC_parse; + char *save_start = RExC_start; Size_t constructed_prefix_len = 0; /* This gives the length of the constructed portion of the substitute parse. */ @@ -18612,20 +18612,20 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * reported. See the comments at the definition of * REPORT_LOCATION_ARGS for details */ RExC_copy_start_in_input = (char *) orig_parse; - RExC_start = RExC_parse = SvPV(substitute_parse, len); + RExC_start = RExC_parse = SvPV(substitute_parse, len); RExC_copy_start_in_constructed = RExC_start + constructed_prefix_len; - RExC_end = RExC_parse + len; + RExC_end = RExC_parse + len; RExC_in_multi_char_class = 1; - ret = reg(pRExC_state, 1, ®_flags, depth+1); + ret = reg(pRExC_state, 1, ®_flags, depth+1); *flagp |= reg_flags & (HASWIDTH|SIMPLE|POSTPONED|RESTART_PARSE|NEED_UTF8); /* And restore so can parse the rest of the pattern */ RExC_parse = save_parse; - RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = save_start; - RExC_end = save_end; - RExC_in_multi_char_class = 0; + RExC_start = RExC_copy_start_in_constructed = RExC_copy_start_in_input = save_start; + RExC_end = save_end; + RExC_in_multi_char_class = 0; SvREFCNT_dec_NN(multi_char_matches); return ret; } @@ -18771,7 +18771,7 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, /* Now that we have finished adding all the folds, there is no reason * to keep the foldable list separate */ _invlist_union(cp_list, cp_foldable_list, &cp_list); - SvREFCNT_dec_NN(cp_foldable_list); + SvREFCNT_dec_NN(cp_foldable_list); } /* And combine the result (if any) with any inversion lists from posix @@ -19007,8 +19007,8 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, { _invlist_invert(cp_list); - /* Clear the invert flag since have just done it here */ - invert = FALSE; + /* Clear the invert flag since have just done it here */ + invert = FALSE; } /* All possible optimizations below still have these characteristics. @@ -19954,15 +19954,15 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * when the target string is UTF-8 (<upper_latin1_only_utf8_matches>). * */ if (upper_latin1_only_utf8_matches) { - if (cp_list) { - _invlist_union(cp_list, + if (cp_list) { + _invlist_union(cp_list, upper_latin1_only_utf8_matches, &cp_list); - SvREFCNT_dec_NN(upper_latin1_only_utf8_matches); - } - else { - cp_list = upper_latin1_only_utf8_matches; - } + SvREFCNT_dec_NN(upper_latin1_only_utf8_matches); + } + else { + cp_list = upper_latin1_only_utf8_matches; + } ANYOF_FLAGS(REGNODE_p(ret)) |= ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP; } @@ -20017,11 +20017,11 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) { assert(! (ANYOF_FLAGS(node) & ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)); - ARG_SET(node, ANYOF_ONLY_HAS_BITMAP); + ARG_SET(node, ANYOF_ONLY_HAS_BITMAP); } else { - AV * const av = newAV(); - SV *rv; + AV * const av = newAV(); + SV *rv; if (cp_list) { av_store(av, INVLIST_INDEX, SvREFCNT_inc_NN(cp_list)); @@ -20040,10 +20040,10 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, SvREFCNT_inc_NN(runtime_defns)); } - rv = newRV_noinc(MUTABLE_SV(av)); - n = add_data(pRExC_state, STR_WITH_LEN("s")); - RExC_rxi->data->data[n] = (void*)rv; - ARG_SET(node, n); + rv = newRV_noinc(MUTABLE_SV(av)); + n = add_data(pRExC_state, STR_WITH_LEN("s")); + RExC_rxi->data->data[n] = (void*)rv; + ARG_SET(node, n); } } @@ -20097,12 +20097,12 @@ Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, assert(! output_invlist || listsvp); if (data && data->count) { - const U32 n = ARG(node); + const U32 n = ARG(node); - if (data->what[n] == 's') { - SV * const rv = MUTABLE_SV(data->data[n]); - AV * const av = MUTABLE_AV(SvRV(rv)); - SV **const ary = AvARRAY(av); + if (data->what[n] == 's') { + SV * const rv = MUTABLE_SV(data->data[n]); + AV * const av = MUTABLE_AV(SvRV(rv)); + SV **const ary = AvARRAY(av); invlist = ary[INVLIST_INDEX]; @@ -20114,7 +20114,7 @@ Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, si = ary[DEFERRED_USER_DEFINED_INDEX]; } - if (doinit && (si || invlist)) { + if (doinit && (si || invlist)) { if (si) { bool user_defined; SV * msg = newSVpvs_flags("", SVs_TEMP); @@ -20156,20 +20156,20 @@ Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, : INVLIST_INDEX); si = NULL; } - } - } + } + } } /* If requested, return a printable version of what this ANYOF node matches * */ if (listsvp) { - SV* matches_string = NULL; + SV* matches_string = NULL; /* This function can be called at compile-time, before everything gets * resolved, in which case we return the currently best available * information, which is the string that will eventually be used to do * that resolving, 'si' */ - if (si) { + if (si) { /* Here, we only have 'si' (and possibly some passed-in data in * 'invlist', which is handled below) If the caller only wants * 'si', use that. */ @@ -20268,7 +20268,7 @@ Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, SvCUR_set(matches_string, SvCUR(matches_string) - 1); } } /* end of has an 'si' */ - } + } /* Add the stuff that's already known */ if (invlist) { @@ -20291,7 +20291,7 @@ Perl_get_re_gclass_nonbitmap_data(pTHX_ const regexp *prog, const regnode* node, } } - *listsvp = matches_string; + *listsvp = matches_string; } return invlist; @@ -20347,21 +20347,21 @@ S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state, assert( ! UTF || UTF8_IS_INVARIANT(**p) || UTF8_IS_START(**p)); for (;;) { - if (RExC_end - (*p) >= 3 - && *(*p) == '(' - && *(*p + 1) == '?' - && *(*p + 2) == '#') - { - while (*(*p) != ')') { - if ((*p) == RExC_end) - FAIL("Sequence (?#... not terminated"); - (*p)++; - } - (*p)++; - continue; - } - - if (use_xmod) { + if (RExC_end - (*p) >= 3 + && *(*p) == '(' + && *(*p + 1) == '?' + && *(*p + 2) == '#') + { + while (*(*p) != ')') { + if ((*p) == RExC_end) + FAIL("Sequence (?#... not terminated"); + (*p)++; + } + (*p)++; + continue; + } + + if (use_xmod) { const char * save_p = *p; while ((*p) < RExC_end) { STRLEN len; @@ -20378,7 +20378,7 @@ S_skip_to_be_ignored_text(pTHX_ RExC_state_t *pRExC_state, if (*p != save_p) { continue; } - } + } break; } @@ -20432,7 +20432,7 @@ S_change_engine_size(pTHX_ RExC_state_t *pRExC_state, const Ptrdiff_t size) char, regexp_internal); if ( RExC_rxi == NULL ) - FAIL("Regexp out of space"); + FAIL("Regexp out of space"); RXi_SET(RExC_rx, RExC_rxi); RExC_emit_start = RExC_rxi->program; @@ -20473,16 +20473,16 @@ S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_ assert(extra_size >= regarglen[op] || PL_regkind[op] == ANYOF); if (RExC_offsets) { /* MJD */ - MJD_OFFSET_DEBUG( + MJD_OFFSET_DEBUG( ("%s:%d: (op %s) %s %" UVuf " (len %" UVuf ") (max %" UVuf ").\n", name, __LINE__, PL_reg_name[op], (UV)(RExC_emit) > RExC_offsets[0] - ? "Overwriting end of array!\n" : "OK", + ? "Overwriting end of array!\n" : "OK", (UV)(RExC_emit), (UV)(RExC_parse - RExC_start), (UV)RExC_offsets[0])); - Set_Node_Offset(REGNODE_p(RExC_emit), RExC_parse + (op == END)); + Set_Node_Offset(REGNODE_p(RExC_emit), RExC_parse + (op == END)); } #endif return(ret); @@ -20627,21 +20627,21 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, const U8 op, RExC_end_op += size; while (src > REGNODE_p(operand)) { - StructCopy(--src, --dst, regnode); + StructCopy(--src, --dst, regnode); #ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD 20010112 */ - MJD_OFFSET_DEBUG( + MJD_OFFSET_DEBUG( ("%s(%d): (op %s) %s copy %" UVuf " -> %" UVuf " (max %" UVuf ").\n", "reginsert", - __LINE__, - PL_reg_name[op], + __LINE__, + PL_reg_name[op], (UV)(REGNODE_OFFSET(dst)) > RExC_offsets[0] - ? "Overwriting end of array!\n" : "OK", + ? "Overwriting end of array!\n" : "OK", (UV)REGNODE_OFFSET(src), (UV)REGNODE_OFFSET(dst), (UV)RExC_offsets[0])); - Set_Node_Offset_To_R(REGNODE_OFFSET(dst), Node_Offset(src)); - Set_Node_Length_To_R(REGNODE_OFFSET(dst), Node_Length(src)); + Set_Node_Offset_To_R(REGNODE_OFFSET(dst), Node_Offset(src)); + Set_Node_Length_To_R(REGNODE_OFFSET(dst), Node_Length(src)); } #endif } @@ -20649,18 +20649,18 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, const U8 op, place = REGNODE_p(operand); /* Op node, where operand used to be. */ #ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD */ - MJD_OFFSET_DEBUG( + MJD_OFFSET_DEBUG( ("%s(%d): (op %s) %s %" UVuf " <- %" UVuf " (max %" UVuf ").\n", "reginsert", - __LINE__, - PL_reg_name[op], + __LINE__, + PL_reg_name[op], (UV)REGNODE_OFFSET(place) > RExC_offsets[0] ? "Overwriting end of array!\n" : "OK", (UV)REGNODE_OFFSET(place), (UV)(RExC_parse - RExC_start), (UV)RExC_offsets[0])); - Set_Node_Offset(place, RExC_parse); - Set_Node_Length(place, 1); + Set_Node_Offset(place, RExC_parse); + Set_Node_Length(place, 1); } #endif src = NEXTOPER(place); @@ -20696,7 +20696,7 @@ S_regtail(pTHX_ RExC_state_t * pRExC_state, * */ scan = (regnode_offset) p; for (;;) { - regnode * const temp = regnext(REGNODE_p(scan)); + regnode * const temp = regnext(REGNODE_p(scan)); DEBUG_PARSE_r({ DEBUG_PARSE_MSG((scan==p ? "tail" : "")); regprop(RExC_rx, RExC_mysv, REGNODE_p(scan), NULL, pRExC_state); @@ -20773,11 +20773,11 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, regnode * const temp = regnext(REGNODE_p(scan)); #ifdef EXPERIMENTAL_INPLACESCAN if (PL_regkind[OP(REGNODE_p(scan))] == EXACT) { - bool unfolded_multi_char; /* Unexamined in this routine */ + bool unfolded_multi_char; /* Unexamined in this routine */ if (join_exact(pRExC_state, scan, &min, &unfolded_multi_char, 1, REGNODE_p(val), depth+1)) return TRUE; /* Was return EXACT */ - } + } #endif if ( exact ) { if (PL_regkind[OP(REGNODE_p(scan))] == EXACT) { @@ -20798,23 +20798,23 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, scan, PL_reg_name[exact]); }); - if (temp == NULL) - break; - scan = REGNODE_OFFSET(temp); + if (temp == NULL) + break; + scan = REGNODE_OFFSET(temp); } DEBUG_PARSE_r({ DEBUG_PARSE_MSG(""); regprop(RExC_rx, RExC_mysv, REGNODE_p(val), NULL, pRExC_state); Perl_re_printf( aTHX_ "~ attach to %s (%" IVdf ") offset to %" IVdf "\n", - SvPV_nolen_const(RExC_mysv), - (IV)val, - (IV)(val - scan) + SvPV_nolen_const(RExC_mysv), + (IV)val, + (IV)(val - scan) ); }); if (reg_off_by_arg[OP(REGNODE_p(scan))]) { assert((UV) (val - scan) <= U32_MAX); - ARG_SET(REGNODE_p(scan), val - scan); + ARG_SET(REGNODE_p(scan), val - scan); } else { if (val - scan > U16_MAX) { @@ -20824,7 +20824,7 @@ S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode_offset p, NEXT_OFF(REGNODE_p(scan)) = U16_MAX; return FALSE; } - NEXT_OFF(REGNODE_p(scan)) = val - scan; + NEXT_OFF(REGNODE_p(scan)) = val - scan; } return TRUE; /* Was 'return exact' */ @@ -20903,9 +20903,9 @@ S_regdump_extflags(pTHX_ const char *lead, const U32 flags) for (bit=0; bit<REG_EXTFLAGS_NAME_SIZE; bit++) { if (flags & (1<<bit)) { - if ((1<<bit) & RXf_PMf_CHARSET) { /* Output separately, below */ - continue; - } + if ((1<<bit) & RXf_PMf_CHARSET) { /* Output separately, below */ + continue; + } if (!set++ && lead) Perl_re_printf( aTHX_ "%s", lead); Perl_re_printf( aTHX_ "%s ", PL_reg_extflags_name[bit]); @@ -20988,10 +20988,10 @@ Perl_regdump(pTHX_ const regexp *r) if (r->check_substr || r->check_utf8) Perl_re_printf( aTHX_ - (const char *) - ( r->check_substr == r->substrs->data[1].substr - && r->check_utf8 == r->substrs->data[1].utf8_substr - ? "(checking floating" : "(checking anchored")); + (const char *) + ( r->check_substr == r->substrs->data[1].substr + && r->check_utf8 == r->substrs->data[1].utf8_substr + ? "(checking floating" : "(checking anchored")); if (r->intflags & PREGf_NOSCAN) Perl_re_printf( aTHX_ " noscan"); if (r->extflags & RXf_CHECK_ALL) @@ -21112,29 +21112,29 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ k = PL_regkind[OP(o)]; if (k == EXACT) { - sv_catpvs(sv, " "); - /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) - * is a crude hack but it may be the best for now since - * we have no flag "this EXACTish node was UTF-8" - * --jhi */ - pv_pretty(sv, STRING(o), STR_LEN(o), PL_dump_re_max_len, + sv_catpvs(sv, " "); + /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) + * is a crude hack but it may be the best for now since + * we have no flag "this EXACTish node was UTF-8" + * --jhi */ + pv_pretty(sv, STRING(o), STR_LEN(o), PL_dump_re_max_len, PL_colors[0], PL_colors[1], - PERL_PV_ESCAPE_UNI_DETECT | - PERL_PV_ESCAPE_NONASCII | - PERL_PV_PRETTY_ELLIPSES | - PERL_PV_PRETTY_LTGT | - PERL_PV_PRETTY_NOCLEAR - ); + PERL_PV_ESCAPE_UNI_DETECT | + PERL_PV_ESCAPE_NONASCII | + PERL_PV_PRETTY_ELLIPSES | + PERL_PV_PRETTY_LTGT | + PERL_PV_PRETTY_NOCLEAR + ); } else if (k == TRIE) { - /* print the details of the trie in dumpuntil instead, as - * progi->data isn't available here */ + /* print the details of the trie in dumpuntil instead, as + * progi->data isn't available here */ const char op = OP(o); const U32 n = ARG(o); const reg_ac_data * const ac = IS_TRIE_AC(op) ? (reg_ac_data *)progi->data->data[n] : NULL; const reg_trie_data * const trie - = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie]; + = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie]; Perl_sv_catpvf(aTHX_ sv, "-%s", PL_reg_name[o->flags]); DEBUG_TRIE_COMPILE_r({ @@ -21167,8 +21167,8 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } } else if (k == CURLY) { U32 lo = ARG1(o), hi = ARG2(o); - if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX) - Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */ + if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX) + Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */ Perl_sv_catpvf(aTHX_ sv, "{%u,", (unsigned) lo); if (hi == REG_INFTY) sv_catpvs(sv, "INFTY"); @@ -21177,14 +21177,14 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ sv_catpvs(sv, "}"); } else if (k == WHILEM && o->flags) /* Ordinal/of */ - Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4); + Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4); else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) { AV *name_list= NULL; U32 parno= OP(o) == ACCEPT ? (U32)ARG2L(o) : ARG(o); Perl_sv_catpvf(aTHX_ sv, "%" UVuf, (UV)parno); /* Parenth number */ - if ( RXp_PAREN_NAMES(prog) ) { + if ( RXp_PAREN_NAMES(prog) ) { name_list= MUTABLE_AV(progi->data->data[progi->name_list_idx]); } else if ( pRExC_state ) { name_list= RExC_paren_name_list; @@ -21192,8 +21192,8 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ if (name_list) { if ( k != REF || (OP(o) < REFN)) { SV **name= av_fetch(name_list, parno, 0 ); - if (name) - Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name)); + if (name) + Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name)); } else { SV *sv_dat= MUTABLE_SV(progi->data->data[ parno ]); @@ -21203,7 +21203,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ if (name) { for ( n=0; n<SvIVX(sv_dat); n++ ) { Perl_sv_catpvf(aTHX_ sv, "%s%" IVdf, - (n ? "," : ""), (IV)nums[n]); + (n ? "," : ""), (IV)nums[n]); } Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name)); } @@ -21242,7 +21242,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } else if (k == LOGICAL) /* 2: embedded, otherwise 1 */ - Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); + Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); else if (k == ANYOF || k == ANYOFR) { U8 flags; char * bitmap; @@ -21274,7 +21274,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ arg = ARG(o); } - if (OP(o) == ANYOFL || OP(o) == ANYOFPOSIXL) { + if (OP(o) == ANYOFL || OP(o) == ANYOFPOSIXL) { if (ANYOFL_UTF8_LOCALE_REQD(flags)) { sv_catpvs(sv, "{utf8-locale-reqd}"); } @@ -21328,7 +21328,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } /* Ready to start outputting. First, the initial left bracket */ - Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); + Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); /* ANYOFH by definition doesn't have anything that will fit inside the * bitmap; ANYOFR may or may not. */ @@ -21433,7 +21433,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } /* And finally the matching, closing ']' */ - Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); + Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); if (OP(o) == ANYOFHs) { Perl_sv_catpvf(aTHX_ sv, " (Leading UTF-8 bytes=%s", _byte_dump_string((U8 *) ((struct regnode_anyofhs *) o)->string, FLAGS(o), 1)); @@ -21464,13 +21464,13 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ else if (k == ANYOFM) { SV * cp_list = get_ANYOFM_contents(o); - Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); + Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]); if (OP(o) == NANYOFM) { _invlist_invert(cp_list); } put_charclass_bitmap_innards(sv, NULL, cp_list, NULL, NULL, 0, TRUE); - Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); + Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); SvREFCNT_dec(cp_list); } @@ -21502,11 +21502,11 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ sv_catpv(sv, bounds[FLAGS(o)]); } else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) { - Perl_sv_catpvf(aTHX_ sv, "[%d", -(o->flags)); + Perl_sv_catpvf(aTHX_ sv, "[%d", -(o->flags)); if (o->next_off) { Perl_sv_catpvf(aTHX_ sv, "..-%d", o->flags - o->next_off); } - Perl_sv_catpvf(aTHX_ sv, "]"); + Perl_sv_catpvf(aTHX_ sv, "]"); } else if (OP(o) == SBOL) Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^"); @@ -21546,22 +21546,22 @@ Perl_re_intuit_string(pTHX_ REGEXP * const r) PERL_UNUSED_CONTEXT; DEBUG_COMPILE_r( - { + { if (prog->maxlen > 0) { const char * const s = SvPV_nolen_const(RX_UTF8(r) - ? prog->check_utf8 : prog->check_substr); + ? prog->check_utf8 : prog->check_substr); if (!PL_colorset) reginitcolors(); Perl_re_printf( aTHX_ - "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n", - PL_colors[4], - RX_UTF8(r) ? "utf8 " : "", - PL_colors[5], PL_colors[0], - s, - PL_colors[1], - (strlen(s) > PL_dump_re_max_len ? "..." : "")); + "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n", + PL_colors[4], + RX_UTF8(r) ? "utf8 " : "", + PL_colors[5], PL_colors[0], + s, + PL_colors[1], + (strlen(s) > PL_dump_re_max_len ? "..." : "")); } - } ); + } ); /* use UTF8 check substring if regexp pattern itself is in UTF8 */ return RX_UTF8(r) ? prog->check_utf8 : prog->check_substr; @@ -21609,7 +21609,7 @@ Perl_pregfree2(pTHX_ REGEXP *rx) SvREFCNT_dec(r->substrs->data[i].substr); SvREFCNT_dec(r->substrs->data[i].utf8_substr); } - Safefree(r->substrs); + Safefree(r->substrs); } RX_MATCH_COPY_FREE(rx); #ifdef PERL_ANY_COW @@ -21656,7 +21656,7 @@ Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv) PERL_ARGS_ASSERT_REG_TEMP_COPY; if (!dsv) - dsv = (REGEXP*) newSV_type(SVt_REGEXP); + dsv = (REGEXP*) newSV_type(SVt_REGEXP); else { assert(SvTYPE(dsv) == SVt_REGEXP || (SvTYPE(dsv) == SVt_PVLV)); @@ -21673,22 +21673,22 @@ Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv) } SvLEN_set(dsv, 0); SvCUR_set(dsv, 0); - SvOK_off((SV *)dsv); + SvOK_off((SV *)dsv); - if (islv) { - /* For PVLVs, the head (sv_any) points to an XPVLV, while + if (islv) { + /* For PVLVs, the head (sv_any) points to an XPVLV, while * the LV's xpvlenu_rx will point to a regexp body, which * we allocate here */ - REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP); - assert(!SvPVX(dsv)); + REGEXP *temp = (REGEXP *)newSV_type(SVt_REGEXP); + assert(!SvPVX(dsv)); ((XPV*)SvANY(dsv))->xpv_len_u.xpvlenu_rx = temp->sv_any; - temp->sv_any = NULL; - SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL; - SvREFCNT_dec_NN(temp); - /* SvCUR still resides in the xpvlv struct, so the regexp copy- - ing below will not set it. */ - SvCUR_set(dsv, SvCUR(ssv)); - } + temp->sv_any = NULL; + SvFLAGS(temp) = (SvFLAGS(temp) & ~SVTYPEMASK) | SVt_NULL; + SvREFCNT_dec_NN(temp); + /* SvCUR still resides in the xpvlv struct, so the regexp copy- + ing below will not set it. */ + SvCUR_set(dsv, SvCUR(ssv)); + } } /* This ensures that SvTHINKFIRST(sv) is true, and hence that sv_force_normal(sv) is called. */ @@ -21702,7 +21702,7 @@ Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv) The string pointer is copied here, being part of the regexp struct. */ memcpy(&(drx->xpv_cur), &(srx->xpv_cur), - sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur)); + sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur)); if (!islv) SvLEN_set(dsv, 0); if (srx->offs) { @@ -21713,15 +21713,15 @@ Perl_reg_temp_copy(pTHX_ REGEXP *dsv, REGEXP *ssv) if (srx->substrs) { int i; Newx(drx->substrs, 1, struct reg_substr_data); - StructCopy(srx->substrs, drx->substrs, struct reg_substr_data); + StructCopy(srx->substrs, drx->substrs, struct reg_substr_data); for (i = 0; i < 2; i++) { SvREFCNT_inc_void(drx->substrs->data[i].substr); SvREFCNT_inc_void(drx->substrs->data[i].utf8_substr); } - /* check_substr and check_utf8, if non-NULL, point to either their - anchored or float namesakes, and don't hold a second reference. */ + /* check_substr and check_utf8, if non-NULL, point to either their + anchored or float namesakes, and don't hold a second reference. */ } RX_MATCH_COPIED_off(dsv); #ifdef PERL_ANY_COW @@ -21763,10 +21763,10 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) } DEBUG_COMPILE_r({ - if (!PL_colorset) - reginitcolors(); - { - SV *dsv= sv_newmortal(); + if (!PL_colorset) + reginitcolors(); + { + SV *dsv= sv_newmortal(); RE_PV_QUOTED_DECL(s, RX_UTF8(rx), dsv, RX_PRECOMP(rx), RX_PRELEN(rx), PL_dump_re_max_len); Perl_re_printf( aTHX_ "%sFreeing REx:%s %s\n", @@ -21782,24 +21782,24 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) S_free_codeblocks(aTHX_ ri->code_blocks); if (ri->data) { - int n = ri->data->count; + int n = ri->data->count; - while (--n >= 0) { + while (--n >= 0) { /* If you add a ->what type here, update the comment in regcomp.h */ - switch (ri->data->what[n]) { - case 'a': - case 'r': - case 's': - case 'S': - case 'u': - SvREFCNT_dec(MUTABLE_SV(ri->data->data[n])); - break; - case 'f': - Safefree(ri->data->data[n]); - break; - case 'l': - case 'L': - break; + switch (ri->data->what[n]) { + case 'a': + case 'r': + case 's': + case 'S': + case 'u': + SvREFCNT_dec(MUTABLE_SV(ri->data->data[n])); + break; + case 'f': + Safefree(ri->data->data[n]); + break; + case 'l': + case 'L': + break; case 'T': { /* Aho Corasick add-on structure for a trie node. Used in stclass optimization only */ @@ -21811,7 +21811,7 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) if ( !refcount ) { PerlMemShared_free(aho->states); PerlMemShared_free(aho->fail); - /* do this last!!!! */ + /* do this last!!!! */ PerlMemShared_free(ri->data->data[n]); /* we should only ever get called once, so * assert as much, and also guard the free @@ -21826,11 +21826,11 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) } } break; - case 't': - { - /* trie structure. */ - U32 refcount; - reg_trie_data *trie=(reg_trie_data*)ri->data->data[n]; + case 't': + { + /* trie structure. */ + U32 refcount; + reg_trie_data *trie=(reg_trie_data*)ri->data->data[n]; OP_REFCNT_LOCK; refcount = --trie->refcount; OP_REFCNT_UNLOCK; @@ -21842,19 +21842,19 @@ Perl_regfree_internal(pTHX_ REGEXP * const rx) PerlMemShared_free(trie->bitmap); if (trie->jump) PerlMemShared_free(trie->jump); - PerlMemShared_free(trie->wordinfo); + PerlMemShared_free(trie->wordinfo); /* do this last!!!! */ PerlMemShared_free(ri->data->data[n]); - } - } - break; - default: - Perl_croak(aTHX_ "panic: regfree data code '%c'", + } + } + break; + default: + Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]); - } - } - Safefree(ri->data->what); - Safefree(ri->data); + } + } + Safefree(ri->data->what); + Safefree(ri->data); } Safefree(ri); @@ -21896,15 +21896,15 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) Copy(r->offs, ret->offs, npar, regexp_paren_pair); if (ret->substrs) { - /* Do it this way to avoid reading from *r after the StructCopy(). - That way, if any of the sv_dup_inc()s dislodge *r from the L1 - cache, it doesn't matter. */ + /* Do it this way to avoid reading from *r after the StructCopy(). + That way, if any of the sv_dup_inc()s dislodge *r from the L1 + cache, it doesn't matter. */ int i; - const bool anchored = r->check_substr - ? r->check_substr == r->substrs->data[0].substr - : r->check_utf8 == r->substrs->data[0].utf8_substr; + const bool anchored = r->check_substr + ? r->check_substr == r->substrs->data[0].substr + : r->check_utf8 == r->substrs->data[0].utf8_substr; Newx(ret->substrs, 1, struct reg_substr_data); - StructCopy(r->substrs, ret->substrs, struct reg_substr_data); + StructCopy(r->substrs, ret->substrs, struct reg_substr_data); for (i = 0; i < 2; i++) { ret->substrs->data[i].substr = @@ -21913,29 +21913,29 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) sv_dup_inc(ret->substrs->data[i].utf8_substr, param); } - /* check_substr and check_utf8, if non-NULL, point to either their - anchored or float namesakes, and don't hold a second reference. */ + /* check_substr and check_utf8, if non-NULL, point to either their + anchored or float namesakes, and don't hold a second reference. */ - if (ret->check_substr) { - if (anchored) { - assert(r->check_utf8 == r->substrs->data[0].utf8_substr); + if (ret->check_substr) { + if (anchored) { + assert(r->check_utf8 == r->substrs->data[0].utf8_substr); - ret->check_substr = ret->substrs->data[0].substr; - ret->check_utf8 = ret->substrs->data[0].utf8_substr; - } else { - assert(r->check_substr == r->substrs->data[1].substr); - assert(r->check_utf8 == r->substrs->data[1].utf8_substr); + ret->check_substr = ret->substrs->data[0].substr; + ret->check_utf8 = ret->substrs->data[0].utf8_substr; + } else { + assert(r->check_substr == r->substrs->data[1].substr); + assert(r->check_utf8 == r->substrs->data[1].utf8_substr); - ret->check_substr = ret->substrs->data[1].substr; - ret->check_utf8 = ret->substrs->data[1].utf8_substr; - } - } else if (ret->check_utf8) { - if (anchored) { - ret->check_utf8 = ret->substrs->data[0].utf8_substr; - } else { - ret->check_utf8 = ret->substrs->data[1].utf8_substr; - } - } + ret->check_substr = ret->substrs->data[1].substr; + ret->check_utf8 = ret->substrs->data[1].utf8_substr; + } + } else if (ret->check_utf8) { + if (anchored) { + ret->check_utf8 = ret->substrs->data[0].utf8_substr; + } else { + ret->check_utf8 = ret->substrs->data[1].utf8_substr; + } + } } RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param); @@ -21944,12 +21944,12 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) Newx(ret->recurse_locinput, r->nparens + 1, char *); if (ret->pprivate) - RXi_SET(ret, CALLREGDUPE_PVT(dstr, param)); + RXi_SET(ret, CALLREGDUPE_PVT(dstr, param)); if (RX_MATCH_COPIED(dstr)) - ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen); + ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen); else - ret->subbeg = NULL; + ret->subbeg = NULL; #ifdef PERL_ANY_COW ret->saved_copy = NULL; #endif @@ -21957,9 +21957,9 @@ Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param) /* Whether mother_re be set or no, we need to copy the string. We cannot refrain from copying it when the storage points directly to our mother regexp, because that's - 1: a buffer in a different thread - 2: something we no longer hold a reference on - so we need to copy it locally. */ + 1: a buffer in a different thread + 2: something we no longer hold a reference on + so we need to copy it locally. */ RX_WRAPPED(dstr) = SAVEPVN(RX_WRAPPED_const(sstr), SvCUR(sstr)+1); /* set malloced length to a non-zero value so it will be freed * (otherwise in combination with SVf_FAKE it looks like an alien @@ -22002,37 +22002,37 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) if (ri->code_blocks) { - int n; - Newx(reti->code_blocks, 1, struct reg_code_blocks); - Newx(reti->code_blocks->cb, ri->code_blocks->count, + int n; + Newx(reti->code_blocks, 1, struct reg_code_blocks); + Newx(reti->code_blocks->cb, ri->code_blocks->count, struct reg_code_block); - Copy(ri->code_blocks->cb, reti->code_blocks->cb, + Copy(ri->code_blocks->cb, reti->code_blocks->cb, ri->code_blocks->count, struct reg_code_block); - for (n = 0; n < ri->code_blocks->count; n++) - reti->code_blocks->cb[n].src_regex = (REGEXP*) - sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param); + for (n = 0; n < ri->code_blocks->count; n++) + reti->code_blocks->cb[n].src_regex = (REGEXP*) + sv_dup_inc((SV*)(ri->code_blocks->cb[n].src_regex), param); reti->code_blocks->count = ri->code_blocks->count; reti->code_blocks->refcnt = 1; } else - reti->code_blocks = NULL; + reti->code_blocks = NULL; reti->regstclass = NULL; if (ri->data) { - struct reg_data *d; + struct reg_data *d; const int count = ri->data->count; - int i; + int i; - Newxc(d, sizeof(struct reg_data) + count*sizeof(void *), - char, struct reg_data); - Newx(d->what, count, U8); + Newxc(d, sizeof(struct reg_data) + count*sizeof(void *), + char, struct reg_data); + Newx(d->what, count, U8); - d->count = count; - for (i = 0; i < count; i++) { - d->what[i] = ri->data->what[i]; - switch (d->what[i]) { - /* see also regcomp.h and regfree_internal() */ + d->count = count; + for (i = 0; i < count; i++) { + d->what[i] = ri->data->what[i]; + switch (d->what[i]) { + /* see also regcomp.h and regfree_internal() */ case 'a': /* actually an AV, but the dup function is identical. values seem to be "plain sv's" generally. */ case 'r': /* a compiled regex (but still just another SV) */ @@ -22042,9 +22042,9 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) case 'S': /* actually an SV, but the dup function is identical. */ case 'u': /* actually an HV, but the dup function is identical. values are "plain sv's" */ - d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param); - break; - case 'f': + d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param); + break; + case 'f': /* Synthetic Start Class - "Fake" charclass we generate to optimize * patterns which could start with several different things. Pre-TRIE * this was more important than it is now, however this still helps @@ -22052,40 +22052,40 @@ Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param) * to [xa]. This is used by Perl_re_intuit_start() and S_find_byclass() * in regexec.c */ - /* This is cheating. */ - Newx(d->data[i], 1, regnode_ssc); - StructCopy(ri->data->data[i], d->data[i], regnode_ssc); - reti->regstclass = (regnode*)d->data[i]; - break; - case 'T': + /* This is cheating. */ + Newx(d->data[i], 1, regnode_ssc); + StructCopy(ri->data->data[i], d->data[i], regnode_ssc); + reti->regstclass = (regnode*)d->data[i]; + break; + case 'T': /* AHO-CORASICK fail table */ /* Trie stclasses are readonly and can thus be shared - * without duplication. We free the stclass in pregfree - * when the corresponding reg_ac_data struct is freed. - */ - reti->regstclass= ri->regstclass; - /* FALLTHROUGH */ - case 't': + * without duplication. We free the stclass in pregfree + * when the corresponding reg_ac_data struct is freed. + */ + reti->regstclass= ri->regstclass; + /* FALLTHROUGH */ + case 't': /* TRIE transition table */ - OP_REFCNT_LOCK; - ((reg_trie_data*)ri->data->data[i])->refcount++; - OP_REFCNT_UNLOCK; - /* FALLTHROUGH */ + OP_REFCNT_LOCK; + ((reg_trie_data*)ri->data->data[i])->refcount++; + OP_REFCNT_UNLOCK; + /* FALLTHROUGH */ case 'l': /* (?{...}) or (??{ ... }) code (cb->block) */ case 'L': /* same when RExC_pm_flags & PMf_HAS_CV and code is not from another regexp */ - d->data[i] = ri->data->data[i]; - break; + d->data[i] = ri->data->data[i]; + break; default: Perl_croak(aTHX_ "panic: re_dup_guts unknown data code '%c'", ri->data->what[i]); - } - } + } + } - reti->data = d; + reti->data = d; } else - reti->data = NULL; + reti->data = NULL; reti->name_list_idx = ri->name_list_idx; @@ -22114,16 +22114,16 @@ Perl_regnext(pTHX_ regnode *p) I32 offset; if (!p) - return(NULL); + return(NULL); if (OP(p) > REGNODE_MAX) { /* regnode.type is unsigned */ - Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", + Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX); } offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p)); if (offset == 0) - return(NULL); + return(NULL); return(p+offset); } @@ -22142,7 +22142,7 @@ S_re_croak(pTHX_ bool utf8, const char* pat,...) PERL_ARGS_ASSERT_RE_CROAK; if (len > 510) - len = 510; + len = 510; Copy(pat, buf, len , char); buf[len] = '\n'; buf[len + 1] = '\0'; @@ -22151,7 +22151,7 @@ S_re_croak(pTHX_ bool utf8, const char* pat,...) va_end(args); message = SvPV_const(msv, len); if (len > 512) - len = 512; + len = 512; Copy(message, buf, len , char); /* len-1 to avoid \n */ Perl_croak(aTHX_ "%" UTF8f, UTF8fARG(utf8, len-1, buf)); @@ -22169,8 +22169,8 @@ Perl_save_re_context(pTHX) /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */ if (PL_curpm) { - const REGEXP * const rx = PM_GETRE(PL_curpm); - if (rx) + const REGEXP * const rx = PM_GETRE(PL_curpm); + if (rx) nparens = RX_NPARENS(rx); } @@ -22209,13 +22209,13 @@ S_put_code_point(pTHX_ SV *sv, UV c) Perl_sv_catpvf(aTHX_ sv, "\\x{%04" UVXf "}", c); } else if (isPRINT(c)) { - const char string = (char) c; + const char string = (char) c; /* We use {phrase} as metanotation in the class, so also escape literal * braces */ - if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}') - sv_catpvs(sv, "\\"); - sv_catpvn(sv, &string, 1); + if (isBACKSLASHED_PUNCT(c) || c == '{' || c == '}') + sv_catpvs(sv, "\\"); + sv_catpvn(sv, &string, 1); } else if (isMNEMONIC_CNTRL(c)) { Perl_sv_catpvf(aTHX_ sv, "%s", cntrl_to_mnemonic((U8) c)); @@ -22782,10 +22782,10 @@ S_put_charclass_bitmap_innards(pTHX_ SV *sv, || ( SvCUR(inverted_display) + inverted_bias < SvCUR(as_is_display) + as_is_bias))) { - sv_catsv(sv, inverted_display); + sv_catsv(sv, inverted_display); } else if (as_is_display) { - sv_catsv(sv, as_is_display); + sv_catsv(sv, as_is_display); } SvREFCNT_dec(as_is_display); @@ -22814,8 +22814,8 @@ S_put_charclass_bitmap_innards(pTHX_ SV *sv, STATIC const regnode * S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, - const regnode *last, const regnode *plast, - SV* sv, I32 indent, U32 depth) + const regnode *last, const regnode *plast, + SV* sv, I32 indent, U32 depth) { U8 op = PSEUDO; /* Arbitrary non-END op. */ const regnode *next; @@ -22836,25 +22836,25 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, while (PL_regkind[op] != END && (!last || node < last)) { assert(node); - /* While that wasn't END last time... */ - NODE_ALIGN(node); - op = OP(node); - if (op == CLOSE || op == SRCLOSE || op == WHILEM) - indent--; - next = regnext((regnode *)node); - - /* Where, what. */ - if (OP(node) == OPTIMIZED) { - if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE)) - optstart = node; - else - goto after_print; - } else - CLEAR_OPTSTART; + /* While that wasn't END last time... */ + NODE_ALIGN(node); + op = OP(node); + if (op == CLOSE || op == SRCLOSE || op == WHILEM) + indent--; + next = regnext((regnode *)node); + + /* Where, what. */ + if (OP(node) == OPTIMIZED) { + if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE)) + optstart = node; + else + goto after_print; + } else + CLEAR_OPTSTART; regprop(r, sv, node, NULL, NULL); Perl_re_printf( aTHX_ "%4" IVdf ":%*s%s", (IV)(node - start), - (int)(2*indent + 1), "", SvPVX_const(sv)); + (int)(2*indent + 1), "", SvPVX_const(sv)); if (OP(node) != OPTIMIZED) { if (next == NULL) /* Next ptr. */ @@ -22868,39 +22868,39 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, } after_print: - if (PL_regkind[(U8)op] == BRANCHJ) { - assert(next); - { + if (PL_regkind[(U8)op] == BRANCHJ) { + assert(next); + { const regnode *nnode = (OP(next) == LONGJMP ? regnext((regnode *)next) : next); if (last && nnode > last) nnode = last; DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode); - } - } - else if (PL_regkind[(U8)op] == BRANCH) { - assert(next); - DUMPUNTIL(NEXTOPER(node), next); - } - else if ( PL_regkind[(U8)op] == TRIE ) { - const regnode *this_trie = node; - const char op = OP(node); + } + } + else if (PL_regkind[(U8)op] == BRANCH) { + assert(next); + DUMPUNTIL(NEXTOPER(node), next); + } + else if ( PL_regkind[(U8)op] == TRIE ) { + const regnode *this_trie = node; + const char op = OP(node); const U32 n = ARG(node); - const reg_ac_data * const ac = op>=AHOCORASICK ? + const reg_ac_data * const ac = op>=AHOCORASICK ? (reg_ac_data *)ri->data->data[n] : NULL; - const reg_trie_data * const trie = - (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie]; + const reg_trie_data * const trie = + (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie]; #ifdef DEBUGGING - AV *const trie_words + AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]); #endif - const regnode *nextbranch= NULL; - I32 word_idx; + const regnode *nextbranch= NULL; + I32 word_idx; SvPVCLEAR(sv); - for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) { - SV ** const elem_ptr = av_fetch(trie_words, word_idx, 0); + for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) { + SV ** const elem_ptr = av_fetch(trie_words, word_idx, 0); Perl_re_indentf( aTHX_ "%s ", indent+3, @@ -22923,41 +22923,41 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, if (dist) { if (!nextbranch) nextbranch= this_trie + trie->jump[0]; - DUMPUNTIL(this_trie + dist, nextbranch); + DUMPUNTIL(this_trie + dist, nextbranch); } if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH) nextbranch= regnext((regnode *)nextbranch); } else { Perl_re_printf( aTHX_ "\n"); - } - } - if (last && next > last) - node= last; - else - node= next; - } - else if ( op == CURLY ) { /* "next" might be very big: optimizer */ - DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, + } + } + if (last && next > last) + node= last; + else + node= next; + } + else if ( op == CURLY ) { /* "next" might be very big: optimizer */ + DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, NEXTOPER(node) + EXTRA_STEP_2ARGS + 1); - } - else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) { - assert(next); - DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next); - } - else if ( op == PLUS || op == STAR) { - DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1); - } - else if (PL_regkind[(U8)op] == EXACT || op == ANYOFHs) { + } + else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) { + assert(next); + DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next); + } + else if ( op == PLUS || op == STAR) { + DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1); + } + else if (PL_regkind[(U8)op] == EXACT || op == ANYOFHs) { /* Literal string, where present. */ - node += NODE_SZ_STR(node) - 1; - node = NEXTOPER(node); - } - else { - node = NEXTOPER(node); - node += regarglen[(U8)op]; - } - if (op == CURLYX || op == OPEN || op == SROPEN) - indent++; + node += NODE_SZ_STR(node) - 1; + node = NEXTOPER(node); + } + else { + node = NEXTOPER(node); + node += regarglen[(U8)op]; + } + if (op == CURLYX || op == OPEN || op == SROPEN) + indent++; } CLEAR_OPTSTART; #ifdef DEBUG_DUMPUNTIL @@ -23218,7 +23218,7 @@ S_compile_wildcard(pTHX_ const char * subpattern, const STRLEN len, STATIC I32 S_execute_wildcard(pTHX_ REGEXP * const prog, char* stringarg, char *strend, - char *strbeg, SSize_t minend, SV *screamer, U32 nosave) + char *strbeg, SSize_t minend, SV *screamer, U32 nosave) { I32 result; DECLARE_AND_GET_RE_DEBUG_FLAGS; @@ -24912,7 +24912,7 @@ S_parse_uniprop_string(pTHX_ COPHH * hinthash = (IN_PERL_COMPILETIME) ? CopHINTHASH_get(&PL_compiling) : CopHINTHASH_get(PL_curcop); - SV * pu_overrides = cophh_fetch_pv(hinthash, "private_use", 0, 0); + SV * pu_overrides = cophh_fetch_pv(hinthash, "private_use", 0, 0); if (UNLIKELY(pu_overrides && SvPOK(pu_overrides))) { @@ -67,7 +67,7 @@ typedef struct regexp_internal { union { - U32 *offsets; /* offset annotations 20001228 MJD + U32 *offsets; /* offset annotations 20001228 MJD data about mapping the program to the string - offsets[0] is proglen when this is used @@ -81,9 +81,9 @@ Used to make it easier to clone and free arbitrary data that the regops need. Often the ARG field of a regop is an index into this structure */ - struct reg_code_blocks *code_blocks;/* positions of literal (?{}) */ + struct reg_code_blocks *code_blocks;/* positions of literal (?{}) */ int name_list_idx; /* Optional data index of an array of paren names */ - regnode program[1]; /* Unwarranted chumminess with compiler. */ + regnode program[1]; /* Unwarranted chumminess with compiler. */ } regexp_internal; #define RXi_SET(x,y) (x)->pprivate = (void*)(y) @@ -256,7 +256,7 @@ struct regnode_ssc { ((1<<32)-1), while on the Cray T90, sizeof(short)==8 and U16_MAX is ((1<<64)-1). To limit stack growth to reasonable sizes, supply a smaller default. - --Andy Dougherty 11 June 1998 + --Andy Dougherty 11 June 1998 */ #if SHORTSIZE > 2 # ifndef REG_INFTY @@ -311,8 +311,8 @@ struct regnode_ssc { #define OP(p) ((p)->type) #define FLAGS(p) ((p)->flags) /* Caution: Doesn't apply to all \ - regnode types. For some, it's the \ - character set of the regnode */ + regnode types. For some, it's the \ + character set of the regnode */ #define STR_LENs(p) (__ASSERT_(OP(p) != LEXACT && OP(p) != LEXACT_REQ8) \ ((struct regnode_string *)p)->str_len) #define STRINGs(p) (__ASSERT_(OP(p) != LEXACT && OP(p) != LEXACT_REQ8) \ @@ -703,7 +703,7 @@ struct regnode_ssc { #define ANYOF_POSIXL_TEST_ANY_SET(p) \ ((ANYOF_FLAGS(p) & ANYOF_MATCHES_POSIXL) \ - && (((regnode_charclass_posixl*)(p))->classflags)) + && (((regnode_charclass_posixl*)(p))->classflags)) #define ANYOF_CLASS_TEST_ANY_SET(p) ANYOF_POSIXL_TEST_ANY_SET(p) /* Since an SSC always has this field, we don't have to test for that; nor do @@ -732,9 +732,9 @@ struct regnode_ssc { #define ANYOF_BITMAP_TEST(p, c) cBOOL(ANYOF_BITMAP_BYTE(p, c) & ANYOF_BIT(c)) #define ANYOF_BITMAP_SETALL(p) \ - memset (ANYOF_BITMAP(p), 255, ANYOF_BITMAP_SIZE) + memset (ANYOF_BITMAP(p), 255, ANYOF_BITMAP_SIZE) #define ANYOF_BITMAP_CLEARALL(p) \ - Zero (ANYOF_BITMAP(p), ANYOF_BITMAP_SIZE) + Zero (ANYOF_BITMAP(p), ANYOF_BITMAP_SIZE) /* * Utility definitions. @@ -884,9 +884,9 @@ struct _reg_trie_state { /* info per word; indexed by wordnum */ typedef struct { U16 prev; /* previous word in acceptance chain; eg in - * zzz|abc|ab/ after matching the chars abc, the - * accepted word is #2, and the previous accepted - * word is #3 */ + * zzz|abc|ab/ after matching the chars abc, the + * accepted word is #2, and the previous accepted + * word is #3 */ U32 len; /* how many chars long is this word? */ U32 accept; /* accept state for this word */ } reg_trie_wordinfo; @@ -1176,11 +1176,11 @@ re.pm, especially to the documentation. #define FIRST_NON_ASCII_DECIMAL_DIGIT 0x660 /* ARABIC_INDIC_DIGIT_ZERO */ typedef enum { - TRADITIONAL_BOUND = _CC_WORDCHAR, - GCB_BOUND, - LB_BOUND, - SB_BOUND, - WB_BOUND + TRADITIONAL_BOUND = _CC_WORDCHAR, + GCB_BOUND, + LB_BOUND, + SB_BOUND, + WB_BOUND } bound_type; /* This unpacks the FLAGS field of ANYOF[HR]x nodes. The value it contains @@ -15,7 +15,7 @@ use strict; my $tap = $ARGV[0] && $ARGV[0] eq '--tap' ? '# ' : ''; foreach my $pl (map {chomp; "regen/$_"} <DATA>) { - my @command = ($^X, '-I.', $pl, @ARGV); + my @command = ($^X, '-I.', '-Ilib', $pl, @ARGV); print "$tap@command\n"; system @command and die "@command failed: $?" @@ -110,11 +110,11 @@ Perl_push_scope(pTHX) { if (UNLIKELY(PL_scopestack_ix == PL_scopestack_max)) { const IV new_max = GROW(PL_scopestack_max); - Renew(PL_scopestack, new_max, I32); + Renew(PL_scopestack, new_max, I32); #ifdef DEBUGGING - Renew(PL_scopestack_name, new_max, const char*); + Renew(PL_scopestack_name, new_max, const char*); #endif - PL_scopestack_max = new_max; + PL_scopestack_max = new_max; } #ifdef DEBUGGING PL_scopestack_name[PL_scopestack_ix] = "unknown"; @@ -195,7 +195,7 @@ Perl_tmps_grow_p(pTHX_ SSize_t ix) SSize_t extend_to = ix; #ifndef STRESS_REALLOC if (ix - PL_tmps_max < 128) - extend_to += (PL_tmps_max < 512) ? 128 : 512; + extend_to += (PL_tmps_max < 512) ? 128 : 512; #endif Renew(PL_tmps_stack, extend_to + 1, SV*); PL_tmps_max = extend_to + 1; @@ -209,14 +209,14 @@ Perl_free_tmps(pTHX) /* XXX should tmps_floor live in cxstack? */ const SSize_t myfloor = PL_tmps_floor; while (PL_tmps_ix > myfloor) { /* clean up after last statement */ - SV* const sv = PL_tmps_stack[PL_tmps_ix--]; + SV* const sv = PL_tmps_stack[PL_tmps_ix--]; #ifdef PERL_POISON - PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB); + PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB); #endif - if (LIKELY(sv)) { - SvTEMP_off(sv); - SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */ - } + if (LIKELY(sv)) { + SvTEMP_off(sv); + SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */ + } } } @@ -349,27 +349,27 @@ Perl_save_gp(pTHX_ GV *gv, I32 empty) save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP); if (empty) { - GP *gp = Perl_newGP(aTHX_ gv); - HV * const stash = GvSTASH(gv); - bool isa_changed = 0; - - if (stash && HvENAME(stash)) { - if (memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA")) - isa_changed = TRUE; - else if (GvCVu(gv)) - /* taking a method out of circulation ("local")*/ + GP *gp = Perl_newGP(aTHX_ gv); + HV * const stash = GvSTASH(gv); + bool isa_changed = 0; + + if (stash && HvENAME(stash)) { + if (memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA")) + isa_changed = TRUE; + else if (GvCVu(gv)) + /* taking a method out of circulation ("local")*/ mro_method_changed_in(stash); - } - if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) { - gp->gp_io = newIO(); - IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START; - } - GvGP_set(gv,gp); - if (isa_changed) mro_isa_changed_in(stash); + } + if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) { + gp->gp_io = newIO(); + IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START; + } + GvGP_set(gv,gp); + if (isa_changed) mro_isa_changed_in(stash); } else { - gp_ref(GvGP(gv)); - GvINTRO_on(gv); + gp_ref(GvGP(gv)); + GvINTRO_on(gv); } } @@ -382,13 +382,13 @@ Perl_save_ary(pTHX_ GV *gv) PERL_ARGS_ASSERT_SAVE_ARY; if (UNLIKELY(!AvREAL(oav) && AvREIFY(oav))) - av_reify(oav); + av_reify(oav); save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV); GvAV(gv) = NULL; av = GvAVn(gv); if (UNLIKELY(SvMAGIC(oav))) - mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE); + mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE); return av; } @@ -400,13 +400,13 @@ Perl_save_hash(pTHX_ GV *gv) PERL_ARGS_ASSERT_SAVE_HASH; save_pushptrptr( - SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV + SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV ); GvHV(gv) = NULL; hv = GvHVn(gv); if (UNLIKELY(SvMAGIC(ohv))) - mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE); + mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE); return hv; } @@ -418,8 +418,8 @@ Perl_save_item(pTHX_ SV *item) PERL_ARGS_ASSERT_SAVE_ITEM; save_pushptrptr(item, /* remember the pointer */ - sv, /* remember the value */ - SAVEt_ITEM); + sv, /* remember the value */ + SAVEt_ITEM); } void @@ -617,8 +617,8 @@ Perl_save_clearsv(pTHX_ SV **svp) ASSERT_CURPAD_ACTIVE("save_clearsv"); SvPADSTALE_off(*svp); /* mark lexical as active */ if (UNLIKELY((offset_shifted >> SAVE_TIGHT_SHIFT) != offset)) { - Perl_croak(aTHX_ "panic: pad offset %" UVuf " out of range (%p-%p)", - offset, svp, PL_curpad); + Perl_croak(aTHX_ "panic: pad offset %" UVuf " out of range (%p-%p)", + offset, svp, PL_curpad); } { @@ -693,7 +693,7 @@ Perl_save_hints(pTHX) { COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling)); if (PL_hints & HINT_LOCALIZE_HH) { - HV *oldhh = GvHV(PL_hintgv); + HV *oldhh = GvHV(PL_hintgv); { dSS_ADD; SS_ADD_INT(PL_hints); @@ -702,17 +702,17 @@ Perl_save_hints(pTHX) SS_ADD_UV(SAVEt_HINTS_HH); SS_ADD_END(4); } - GvHV(PL_hintgv) = NULL; /* in case copying dies */ - GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh); + GvHV(PL_hintgv) = NULL; /* in case copying dies */ + GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh); SAVEFEATUREBITS(); } else { - save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS); + save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS); } } static void S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2, - const int type) + const int type) { dSS_ADD; SS_ADD_PTR(ptr1); @@ -724,7 +724,7 @@ S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2, void Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr, - const U32 flags) + const U32 flags) { dSS_ADD; SV *sv; @@ -740,17 +740,17 @@ Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr, /* The array needs to hold a reference count on its new element, so it must be AvREAL. */ if (UNLIKELY(!AvREAL(av) && AvREIFY(av))) - av_reify(av); + av_reify(av); save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */ if (flags & SAVEf_KEEPOLDELEM) - return; + return; sv = *sptr; /* If we're localizing a tied array element, this new sv * won't actually be stored in the array - so it won't get * reaped when the localize ends. Ensure it gets reaped by * mortifying it instead. DAPM */ if (UNLIKELY(SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) - sv_2mortal(sv); + sv_2mortal(sv); } void @@ -771,14 +771,14 @@ Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags) } save_scalar_at(sptr, flags); if (flags & SAVEf_KEEPOLDELEM) - return; + return; sv = *sptr; /* If we're localizing a tied hash element, this new sv * won't actually be stored in the hash - so it won't get * reaped when the localize ends. Ensure it gets reaped by * mortifying it instead. DAPM */ if (UNLIKELY(SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))) - sv_2mortal(sv); + sv_2mortal(sv); } SV* @@ -812,9 +812,9 @@ Perl_save_alloc(pTHX_ I32 size, I32 pad) const UV elems_shifted = elems << SAVE_TIGHT_SHIFT; if (UNLIKELY((elems_shifted >> SAVE_TIGHT_SHIFT) != elems)) - Perl_croak(aTHX_ + Perl_croak(aTHX_ "panic: save_alloc elems %" UVuf " out of range (%" IVdf "-%" IVdf ")", - elems, (IV)size, (IV)pad); + elems, (IV)size, (IV)pad); SSGROW(elems + 1); @@ -891,16 +891,16 @@ Perl_leave_scope(pTHX_ I32 base) bool was = TAINT_get; if (UNLIKELY(base < -1)) - Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base); + Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base); DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n", - (long)PL_savestack_ix, (long)base)); + (long)PL_savestack_ix, (long)base)); while (PL_savestack_ix > base) { - UV uv; - U8 type; + UV uv; + U8 type; ANY *ap; /* arg pointer */ ANY a0, a1, a2; /* up to 3 args */ - TAINT_NOT; + TAINT_NOT; { U8 argcount; @@ -914,34 +914,34 @@ Perl_leave_scope(pTHX_ I32 base) ap -= argcount; } - switch (type) { - case SAVEt_ITEM: /* normal string */ + switch (type) { + case SAVEt_ITEM: /* normal string */ a0 = ap[0]; a1 = ap[1]; - sv_replace(a0.any_sv, a1.any_sv); + sv_replace(a0.any_sv, a1.any_sv); if (UNLIKELY(SvSMAGICAL(a0.any_sv))) { PL_localizing = 2; mg_set(a0.any_sv); PL_localizing = 0; } - break; + break; - /* This would be a mathom, but Perl_save_svref() calls a static - function, S_save_scalar_at(), so has to stay in this file. */ - case SAVEt_SVREF: /* scalar reference */ + /* This would be a mathom, but Perl_save_svref() calls a static + function, S_save_scalar_at(), so has to stay in this file. */ + case SAVEt_SVREF: /* scalar reference */ a0 = ap[0]; a1 = ap[1]; - a2.any_svp = a0.any_svp; - a0.any_sv = NULL; /* what to refcnt_dec */ - goto restore_sv; + a2.any_svp = a0.any_svp; + a0.any_sv = NULL; /* what to refcnt_dec */ + goto restore_sv; - case SAVEt_SV: /* scalar reference */ + case SAVEt_SV: /* scalar reference */ a0 = ap[0]; a1 = ap[1]; - a2.any_svp = &GvSV(a0.any_gv); - restore_sv: + a2.any_svp = &GvSV(a0.any_gv); + restore_sv: { /* do *a2.any_svp = a1 and free a0 */ - SV * const sv = *a2.any_svp; - *a2.any_svp = a1.any_sv; - SvREFCNT_dec(sv); + SV * const sv = *a2.any_svp; + *a2.any_svp = a1.any_sv; + SvREFCNT_dec(sv); if (UNLIKELY(SvSMAGICAL(a1.any_sv))) { /* mg_set could die, skipping the freeing of a0 and * a1; Ensure that they're always freed in that case */ @@ -956,73 +956,73 @@ Perl_leave_scope(pTHX_ I32 base) PL_localizing = 0; break; } - SvREFCNT_dec_NN(a1.any_sv); - SvREFCNT_dec(a0.any_sv); - break; + SvREFCNT_dec_NN(a1.any_sv); + SvREFCNT_dec(a0.any_sv); + break; } - case SAVEt_GENERIC_PVREF: /* generic pv */ + case SAVEt_GENERIC_PVREF: /* generic pv */ a0 = ap[0]; a1 = ap[1]; - if (*a1.any_pvp != a0.any_pv) { - Safefree(*a1.any_pvp); - *a1.any_pvp = a0.any_pv; - } - break; + if (*a1.any_pvp != a0.any_pv) { + Safefree(*a1.any_pvp); + *a1.any_pvp = a0.any_pv; + } + break; - case SAVEt_SHARED_PVREF: /* shared pv */ + case SAVEt_SHARED_PVREF: /* shared pv */ a0 = ap[0]; a1 = ap[1]; - if (*a0.any_pvp != a1.any_pv) { + if (*a0.any_pvp != a1.any_pv) { #ifdef NETWARE - PerlMem_free(*a0.any_pvp); + PerlMem_free(*a0.any_pvp); #else - PerlMemShared_free(*a0.any_pvp); + PerlMemShared_free(*a0.any_pvp); #endif - *a0.any_pvp = a1.any_pv; - } - break; + *a0.any_pvp = a1.any_pv; + } + break; - case SAVEt_GVSV: /* scalar slot in GV */ + case SAVEt_GVSV: /* scalar slot in GV */ a0 = ap[0]; a1 = ap[1]; - a0.any_svp = &GvSV(a0.any_gv); - goto restore_svp; + a0.any_svp = &GvSV(a0.any_gv); + goto restore_svp; - case SAVEt_GENERIC_SVREF: /* generic sv */ + case SAVEt_GENERIC_SVREF: /* generic sv */ a0 = ap[0]; a1 = ap[1]; - restore_svp: + restore_svp: { /* do *a0.any_svp = a1 */ - SV * const sv = *a0.any_svp; - *a0.any_svp = a1.any_sv; - SvREFCNT_dec(sv); - SvREFCNT_dec(a1.any_sv); - break; + SV * const sv = *a0.any_svp; + *a0.any_svp = a1.any_sv; + SvREFCNT_dec(sv); + SvREFCNT_dec(a1.any_sv); + break; } - case SAVEt_GVSLOT: /* any slot in GV */ + case SAVEt_GVSLOT: /* any slot in GV */ { HV * hv; a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; hv = GvSTASH(a0.any_gv); - if (hv && HvENAME(hv) && ( - (a2.any_sv && SvTYPE(a2.any_sv) == SVt_PVCV) - || (*a1.any_svp && SvTYPE(*a1.any_svp) == SVt_PVCV) - )) - { - if ((char *)a1.any_svp < (char *)GvGP(a0.any_gv) - || (char *)a1.any_svp > (char *)GvGP(a0.any_gv) + sizeof(struct gp) - || GvREFCNT(a0.any_gv) > 2) /* "> 2" to ignore savestack's ref */ - PL_sub_generation++; - else mro_method_changed_in(hv); - } + if (hv && HvENAME(hv) && ( + (a2.any_sv && SvTYPE(a2.any_sv) == SVt_PVCV) + || (*a1.any_svp && SvTYPE(*a1.any_svp) == SVt_PVCV) + )) + { + if ((char *)a1.any_svp < (char *)GvGP(a0.any_gv) + || (char *)a1.any_svp > (char *)GvGP(a0.any_gv) + sizeof(struct gp) + || GvREFCNT(a0.any_gv) > 2) /* "> 2" to ignore savestack's ref */ + PL_sub_generation++; + else mro_method_changed_in(hv); + } a0.any_svp = a1.any_svp; a1.any_sv = a2.any_sv; - goto restore_svp; + goto restore_svp; } - case SAVEt_AV: /* array reference */ + case SAVEt_AV: /* array reference */ a0 = ap[0]; a1 = ap[1]; - SvREFCNT_dec(GvAV(a0.any_gv)); - GvAV(a0.any_gv) = a1.any_av; + SvREFCNT_dec(GvAV(a0.any_gv)); + GvAV(a0.any_gv) = a1.any_av; avhv_common: if (UNLIKELY(SvSMAGICAL(a1.any_sv))) { /* mg_set might die, so make sure a0 isn't leaked */ @@ -1035,141 +1035,141 @@ Perl_leave_scope(pTHX_ I32 base) PL_localizing = 0; break; } - SvREFCNT_dec_NN(a0.any_sv); - break; + SvREFCNT_dec_NN(a0.any_sv); + break; - case SAVEt_HV: /* hash reference */ + case SAVEt_HV: /* hash reference */ a0 = ap[0]; a1 = ap[1]; - SvREFCNT_dec(GvHV(a0.any_gv)); - GvHV(a0.any_gv) = a1.any_hv; + SvREFCNT_dec(GvHV(a0.any_gv)); + GvHV(a0.any_gv) = a1.any_hv; goto avhv_common; - case SAVEt_INT_SMALL: + case SAVEt_INT_SMALL: a0 = ap[0]; - *(int*)a0.any_ptr = (int)(uv >> SAVE_TIGHT_SHIFT); - break; + *(int*)a0.any_ptr = (int)(uv >> SAVE_TIGHT_SHIFT); + break; - case SAVEt_INT: /* int reference */ + case SAVEt_INT: /* int reference */ a0 = ap[0]; a1 = ap[1]; - *(int*)a1.any_ptr = (int)a0.any_i32; - break; + *(int*)a1.any_ptr = (int)a0.any_i32; + break; case SAVEt_STRLEN_SMALL: - a0 = ap[0]; - *(STRLEN*)a0.any_ptr = (STRLEN)(uv >> SAVE_TIGHT_SHIFT); + a0 = ap[0]; + *(STRLEN*)a0.any_ptr = (STRLEN)(uv >> SAVE_TIGHT_SHIFT); break; - case SAVEt_STRLEN: /* STRLEN/size_t ref */ + case SAVEt_STRLEN: /* STRLEN/size_t ref */ a0 = ap[0]; a1 = ap[1]; - *(STRLEN*)a1.any_ptr = (STRLEN)a0.any_iv; - break; + *(STRLEN*)a1.any_ptr = (STRLEN)a0.any_iv; + break; - case SAVEt_TMPSFLOOR: /* restore PL_tmps_floor */ + case SAVEt_TMPSFLOOR: /* restore PL_tmps_floor */ a0 = ap[0]; - PL_tmps_floor = (SSize_t)a0.any_iv; - break; + PL_tmps_floor = (SSize_t)a0.any_iv; + break; - case SAVEt_BOOL: /* bool reference */ + case SAVEt_BOOL: /* bool reference */ a0 = ap[0]; - *(bool*)a0.any_ptr = cBOOL(uv >> 8); + *(bool*)a0.any_ptr = cBOOL(uv >> 8); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(was); #else - if (UNLIKELY(a0.any_ptr == &(PL_tainted))) { - /* If we don't update <was>, to reflect what was saved on the - * stack for PL_tainted, then we will overwrite this attempt to - * restore it when we exit this routine. Note that this won't - * work if this value was saved in a wider-than necessary type, - * such as I32 */ - was = *(bool*)a0.any_ptr; - } + if (UNLIKELY(a0.any_ptr == &(PL_tainted))) { + /* If we don't update <was>, to reflect what was saved on the + * stack for PL_tainted, then we will overwrite this attempt to + * restore it when we exit this routine. Note that this won't + * work if this value was saved in a wider-than necessary type, + * such as I32 */ + was = *(bool*)a0.any_ptr; + } #endif - break; + break; - case SAVEt_I32_SMALL: + case SAVEt_I32_SMALL: a0 = ap[0]; - *(I32*)a0.any_ptr = (I32)(uv >> SAVE_TIGHT_SHIFT); - break; + *(I32*)a0.any_ptr = (I32)(uv >> SAVE_TIGHT_SHIFT); + break; - case SAVEt_I32: /* I32 reference */ + case SAVEt_I32: /* I32 reference */ a0 = ap[0]; a1 = ap[1]; #ifdef PERL_DEBUG_READONLY_OPS if (*(I32*)a1.any_ptr != a0.any_i32) #endif *(I32*)a1.any_ptr = a0.any_i32; - break; + break; - case SAVEt_SPTR: /* SV* reference */ - case SAVEt_VPTR: /* random* reference */ - case SAVEt_PPTR: /* char* reference */ - case SAVEt_HPTR: /* HV* reference */ - case SAVEt_APTR: /* AV* reference */ + case SAVEt_SPTR: /* SV* reference */ + case SAVEt_VPTR: /* random* reference */ + case SAVEt_PPTR: /* char* reference */ + case SAVEt_HPTR: /* HV* reference */ + case SAVEt_APTR: /* AV* reference */ a0 = ap[0]; a1 = ap[1]; - *a1.any_svp= a0.any_sv; - break; + *a1.any_svp= a0.any_sv; + break; - case SAVEt_GP: /* scalar reference */ + case SAVEt_GP: /* scalar reference */ { HV *hv; - bool had_method; + bool had_method; a0 = ap[0]; a1 = ap[1]; /* possibly taking a method out of circulation */ - had_method = !!GvCVu(a0.any_gv); - gp_free(a0.any_gv); - GvGP_set(a0.any_gv, (GP*)a1.any_ptr); - if ((hv=GvSTASH(a0.any_gv)) && HvENAME_get(hv)) { - if (memEQs(GvNAME(a0.any_gv), GvNAMELEN(a0.any_gv), "ISA")) - mro_isa_changed_in(hv); + had_method = !!GvCVu(a0.any_gv); + gp_free(a0.any_gv); + GvGP_set(a0.any_gv, (GP*)a1.any_ptr); + if ((hv=GvSTASH(a0.any_gv)) && HvENAME_get(hv)) { + if (memEQs(GvNAME(a0.any_gv), GvNAMELEN(a0.any_gv), "ISA")) + mro_isa_changed_in(hv); else if (had_method || GvCVu(a0.any_gv)) /* putting a method back into circulation ("local")*/ gv_method_changed(a0.any_gv); - } - SvREFCNT_dec_NN(a0.any_gv); - break; + } + SvREFCNT_dec_NN(a0.any_gv); + break; } - case SAVEt_FREESV: + case SAVEt_FREESV: a0 = ap[0]; - SvREFCNT_dec(a0.any_sv); - break; + SvREFCNT_dec(a0.any_sv); + break; - case SAVEt_FREEPADNAME: + case SAVEt_FREEPADNAME: a0 = ap[0]; - PadnameREFCNT_dec((PADNAME *)a0.any_ptr); - break; + PadnameREFCNT_dec((PADNAME *)a0.any_ptr); + break; - case SAVEt_FREECOPHH: + case SAVEt_FREECOPHH: a0 = ap[0]; - cophh_free((COPHH *)a0.any_ptr); - break; + cophh_free((COPHH *)a0.any_ptr); + break; - case SAVEt_MORTALIZESV: + case SAVEt_MORTALIZESV: a0 = ap[0]; - sv_2mortal(a0.any_sv); - break; + sv_2mortal(a0.any_sv); + break; - case SAVEt_FREEOP: + case SAVEt_FREEOP: a0 = ap[0]; - ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); - op_free(a0.any_op); - break; + ASSERT_CURPAD_LEGAL("SAVEt_FREEOP"); + op_free(a0.any_op); + break; - case SAVEt_FREEPV: + case SAVEt_FREEPV: a0 = ap[0]; - Safefree(a0.any_ptr); - break; + Safefree(a0.any_ptr); + break; case SAVEt_CLEARPADRANGE: { I32 i; - SV **svp; + SV **svp; i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK); svp = &PL_curpad[uv >> (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1; goto clearsv; - case SAVEt_CLEARSV: - svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT]; + case SAVEt_CLEARSV: + svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT]; i = 1; clearsv: for (; i; i--, svp--) { @@ -1276,10 +1276,10 @@ Perl_leave_scope(pTHX_ I32 base) SvFLAGS(*svp) |= SVs_PADSTALE; } } - break; + break; } - case SAVEt_DELETE: + case SAVEt_DELETE: a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; /* hv_delete could die, so free the key and SvREFCNT_dec the * hv by pushing new save actions @@ -1289,10 +1289,10 @@ Perl_leave_scope(pTHX_ I32 base) /* ap[2] is the hv */ ap[3].any_uv = SAVEt_FREESV; /* was SAVEt_DELETE */ PL_savestack_ix += 4; - (void)hv_delete(a2.any_hv, a0.any_pv, a1.any_i32, G_DISCARD); - break; + (void)hv_delete(a2.any_hv, a0.any_pv, a1.any_i32, G_DISCARD); + break; - case SAVEt_ADELETE: + case SAVEt_ADELETE: a0 = ap[0]; a1 = ap[1]; /* av_delete could die, so SvREFCNT_dec the av by pushing a * new save action @@ -1300,196 +1300,196 @@ Perl_leave_scope(pTHX_ I32 base) ap[0].any_av = a1.any_av; ap[1].any_uv = SAVEt_FREESV; PL_savestack_ix += 2; - (void)av_delete(a1.any_av, a0.any_iv, G_DISCARD); - break; + (void)av_delete(a1.any_av, a0.any_iv, G_DISCARD); + break; - case SAVEt_DESTRUCTOR_X: + case SAVEt_DESTRUCTOR_X: a0 = ap[0]; a1 = ap[1]; - (*a0.any_dxptr)(aTHX_ a1.any_ptr); - break; + (*a0.any_dxptr)(aTHX_ a1.any_ptr); + break; - case SAVEt_REGCONTEXT: - /* regexp must have croaked */ - case SAVEt_ALLOC: - PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT; - break; + case SAVEt_REGCONTEXT: + /* regexp must have croaked */ + case SAVEt_ALLOC: + PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT; + break; - case SAVEt_STACK_POS: /* Position on Perl stack */ + case SAVEt_STACK_POS: /* Position on Perl stack */ a0 = ap[0]; - PL_stack_sp = PL_stack_base + a0.any_i32; - break; + PL_stack_sp = PL_stack_base + a0.any_i32; + break; - case SAVEt_AELEM: /* array element */ + case SAVEt_AELEM: /* array element */ { SV **svp; a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; - svp = av_fetch(a0.any_av, a1.any_iv, 1); - if (UNLIKELY(!AvREAL(a0.any_av) && AvREIFY(a0.any_av))) /* undo reify guard */ - SvREFCNT_dec(a2.any_sv); - if (LIKELY(svp)) { - SV * const sv = *svp; - if (LIKELY(sv && sv != &PL_sv_undef)) { - if (UNLIKELY(SvTIED_mg((const SV *)a0.any_av, PERL_MAGIC_tied))) - SvREFCNT_inc_void_NN(sv); + svp = av_fetch(a0.any_av, a1.any_iv, 1); + if (UNLIKELY(!AvREAL(a0.any_av) && AvREIFY(a0.any_av))) /* undo reify guard */ + SvREFCNT_dec(a2.any_sv); + if (LIKELY(svp)) { + SV * const sv = *svp; + if (LIKELY(sv && sv != &PL_sv_undef)) { + if (UNLIKELY(SvTIED_mg((const SV *)a0.any_av, PERL_MAGIC_tied))) + SvREFCNT_inc_void_NN(sv); a1.any_sv = a2.any_sv; a2.any_svp = svp; - goto restore_sv; - } - } - SvREFCNT_dec(a0.any_av); - SvREFCNT_dec(a2.any_sv); - break; + goto restore_sv; + } + } + SvREFCNT_dec(a0.any_av); + SvREFCNT_dec(a2.any_sv); + break; } - case SAVEt_HELEM: /* hash element */ + case SAVEt_HELEM: /* hash element */ { - HE *he; + HE *he; a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; - he = hv_fetch_ent(a0.any_hv, a1.any_sv, 1, 0); - SvREFCNT_dec(a1.any_sv); - if (LIKELY(he)) { - const SV * const oval = HeVAL(he); - if (LIKELY(oval && oval != &PL_sv_undef)) { + he = hv_fetch_ent(a0.any_hv, a1.any_sv, 1, 0); + SvREFCNT_dec(a1.any_sv); + if (LIKELY(he)) { + const SV * const oval = HeVAL(he); + if (LIKELY(oval && oval != &PL_sv_undef)) { SV **svp = &HeVAL(he); - if (UNLIKELY(SvTIED_mg((const SV *)a0.any_hv, PERL_MAGIC_tied))) - SvREFCNT_inc_void(*svp); + if (UNLIKELY(SvTIED_mg((const SV *)a0.any_hv, PERL_MAGIC_tied))) + SvREFCNT_inc_void(*svp); a1.any_sv = a2.any_sv; a2.any_svp = svp; - goto restore_sv; - } - } - SvREFCNT_dec(a0.any_hv); - SvREFCNT_dec(a2.any_sv); - break; + goto restore_sv; + } + } + SvREFCNT_dec(a0.any_hv); + SvREFCNT_dec(a2.any_sv); + break; } - case SAVEt_OP: + case SAVEt_OP: a0 = ap[0]; - PL_op = (OP*)a0.any_ptr; - break; + PL_op = (OP*)a0.any_ptr; + break; case SAVEt_HINTS_HH: a2 = ap[2]; /* FALLTHROUGH */ case SAVEt_HINTS: a0 = ap[0]; a1 = ap[1]; - if ((PL_hints & HINT_LOCALIZE_HH)) { - while (GvHV(PL_hintgv)) { - HV *hv = GvHV(PL_hintgv); - GvHV(PL_hintgv) = NULL; - SvREFCNT_dec(MUTABLE_SV(hv)); - } - } - cophh_free(CopHINTHASH_get(&PL_compiling)); - CopHINTHASH_set(&PL_compiling, (COPHH*)a1.any_ptr); - *(I32*)&PL_hints = a0.any_i32; - if (type == SAVEt_HINTS_HH) { - SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv))); + if ((PL_hints & HINT_LOCALIZE_HH)) { + while (GvHV(PL_hintgv)) { + HV *hv = GvHV(PL_hintgv); + GvHV(PL_hintgv) = NULL; + SvREFCNT_dec(MUTABLE_SV(hv)); + } + } + cophh_free(CopHINTHASH_get(&PL_compiling)); + CopHINTHASH_set(&PL_compiling, (COPHH*)a1.any_ptr); + *(I32*)&PL_hints = a0.any_i32; + if (type == SAVEt_HINTS_HH) { + SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv))); GvHV(PL_hintgv) = MUTABLE_HV(a2.any_ptr); - } - if (!GvHV(PL_hintgv)) { - /* Need to add a new one manually, else rv2hv can - add one via GvHVn and it won't have the magic set. */ - HV *const hv = newHV(); - hv_magic(hv, NULL, PERL_MAGIC_hints); - GvHV(PL_hintgv) = hv; - } - assert(GvHV(PL_hintgv)); - break; - - case SAVEt_COMPPAD: + } + if (!GvHV(PL_hintgv)) { + /* Need to add a new one manually, else rv2hv can + add one via GvHVn and it won't have the magic set. */ + HV *const hv = newHV(); + hv_magic(hv, NULL, PERL_MAGIC_hints); + GvHV(PL_hintgv) = hv; + } + assert(GvHV(PL_hintgv)); + break; + + case SAVEt_COMPPAD: a0 = ap[0]; - PL_comppad = (PAD*)a0.any_ptr; - if (LIKELY(PL_comppad)) - PL_curpad = AvARRAY(PL_comppad); - else - PL_curpad = NULL; - break; + PL_comppad = (PAD*)a0.any_ptr; + if (LIKELY(PL_comppad)) + PL_curpad = AvARRAY(PL_comppad); + else + PL_curpad = NULL; + break; - case SAVEt_PADSV_AND_MORTALIZE: - { - SV **svp; + case SAVEt_PADSV_AND_MORTALIZE: + { + SV **svp; a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; - assert (a1.any_ptr); - svp = AvARRAY((PAD*)a1.any_ptr) + (PADOFFSET)a2.any_uv; + assert (a1.any_ptr); + svp = AvARRAY((PAD*)a1.any_ptr) + (PADOFFSET)a2.any_uv; /* This mortalizing used to be done by CX_POOPLOOP() via itersave. But as we have all the information here, we can do it here, save even having to have itersave in the struct. */ - sv_2mortal(*svp); - *svp = a0.any_sv; - } - break; + sv_2mortal(*svp); + *svp = a0.any_sv; + } + break; - case SAVEt_SAVESWITCHSTACK: - { - dSP; + case SAVEt_SAVESWITCHSTACK: + { + dSP; a0 = ap[0]; a1 = ap[1]; - SWITCHSTACK(a1.any_av, a0.any_av); - PL_curstackinfo->si_stack = a0.any_av; - } - break; + SWITCHSTACK(a1.any_av, a0.any_av); + PL_curstackinfo->si_stack = a0.any_av; + } + break; - case SAVEt_SET_SVFLAGS: + case SAVEt_SET_SVFLAGS: a0 = ap[0]; a1 = ap[1]; a2 = ap[2]; SvFLAGS(a0.any_sv) &= ~(a1.any_u32); SvFLAGS(a0.any_sv) |= a2.any_u32; - break; + break; - /* These are only saved in mathoms.c */ - case SAVEt_NSTAB: + /* These are only saved in mathoms.c */ + case SAVEt_NSTAB: a0 = ap[0]; - (void)sv_clear(a0.any_sv); - break; + (void)sv_clear(a0.any_sv); + break; - case SAVEt_LONG: /* long reference */ + case SAVEt_LONG: /* long reference */ a0 = ap[0]; a1 = ap[1]; - *(long*)a1.any_ptr = a0.any_long; - break; + *(long*)a1.any_ptr = a0.any_long; + break; - case SAVEt_IV: /* IV reference */ + case SAVEt_IV: /* IV reference */ a0 = ap[0]; a1 = ap[1]; - *(IV*)a1.any_ptr = a0.any_iv; - break; + *(IV*)a1.any_ptr = a0.any_iv; + break; - case SAVEt_I16: /* I16 reference */ + case SAVEt_I16: /* I16 reference */ a0 = ap[0]; - *(I16*)a0.any_ptr = (I16)(uv >> 8); - break; + *(I16*)a0.any_ptr = (I16)(uv >> 8); + break; - case SAVEt_I8: /* I8 reference */ + case SAVEt_I8: /* I8 reference */ a0 = ap[0]; - *(I8*)a0.any_ptr = (I8)(uv >> 8); - break; + *(I8*)a0.any_ptr = (I8)(uv >> 8); + break; - case SAVEt_DESTRUCTOR: + case SAVEt_DESTRUCTOR: a0 = ap[0]; a1 = ap[1]; - (*a0.any_dptr)(a1.any_ptr); - break; + (*a0.any_dptr)(a1.any_ptr); + break; - case SAVEt_COMPILE_WARNINGS: + case SAVEt_COMPILE_WARNINGS: a0 = ap[0]; free_and_set_cop_warnings(&PL_compiling, (STRLEN*) a0.any_ptr); - break; + break; - case SAVEt_PARSER: + case SAVEt_PARSER: a0 = ap[0]; - parser_free((yy_parser *)a0.any_ptr); - break; + parser_free((yy_parser *)a0.any_ptr); + break; - case SAVEt_READONLY_OFF: + case SAVEt_READONLY_OFF: a0 = ap[0]; - SvREADONLY_off(a0.any_sv); - break; + SvREADONLY_off(a0.any_sv); + break; - default: - Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", + default: + Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", (U8)uv & SAVE_MASK); - } + } } TAINT_set(was); @@ -1503,119 +1503,119 @@ Perl_cx_dump(pTHX_ PERL_CONTEXT *cx) #ifdef DEBUGGING PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]); if (CxTYPE(cx) != CXt_SUBST) { - const char *gimme_text; - PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); - PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%" UVxf "\n", - PTR2UV(cx->blk_oldcop)); - PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp); - PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp); - PerlIO_printf(Perl_debug_log, "BLK_OLDSAVEIX = %ld\n", (long)cx->blk_oldsaveix); - PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%" UVxf "\n", - PTR2UV(cx->blk_oldpm)); - switch (cx->blk_gimme) { - case G_VOID: - gimme_text = "VOID"; - break; - case G_SCALAR: - gimme_text = "SCALAR"; - break; - case G_ARRAY: - gimme_text = "LIST"; - break; - default: - gimme_text = "UNKNOWN"; - break; - } - PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text); + const char *gimme_text; + PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); + PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%" UVxf "\n", + PTR2UV(cx->blk_oldcop)); + PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp); + PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp); + PerlIO_printf(Perl_debug_log, "BLK_OLDSAVEIX = %ld\n", (long)cx->blk_oldsaveix); + PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%" UVxf "\n", + PTR2UV(cx->blk_oldpm)); + switch (cx->blk_gimme) { + case G_VOID: + gimme_text = "VOID"; + break; + case G_SCALAR: + gimme_text = "SCALAR"; + break; + case G_ARRAY: + gimme_text = "LIST"; + break; + default: + gimme_text = "UNKNOWN"; + break; + } + PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text); } switch (CxTYPE(cx)) { case CXt_NULL: case CXt_BLOCK: - break; + break; case CXt_FORMAT: - PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%" UVxf "\n", - PTR2UV(cx->blk_format.cv)); - PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%" UVxf "\n", - PTR2UV(cx->blk_format.gv)); - PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%" UVxf "\n", - PTR2UV(cx->blk_format.dfoutgv)); - PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n", - (int)CxHASARGS(cx)); - PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%" UVxf "\n", - PTR2UV(cx->blk_format.retop)); - break; + PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%" UVxf "\n", + PTR2UV(cx->blk_format.cv)); + PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%" UVxf "\n", + PTR2UV(cx->blk_format.gv)); + PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%" UVxf "\n", + PTR2UV(cx->blk_format.dfoutgv)); + PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n", + (int)CxHASARGS(cx)); + PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%" UVxf "\n", + PTR2UV(cx->blk_format.retop)); + break; case CXt_SUB: - PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%" UVxf "\n", - PTR2UV(cx->blk_sub.cv)); - PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", - (long)cx->blk_sub.olddepth); - PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", - (int)CxHASARGS(cx)); - PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx)); - PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%" UVxf "\n", - PTR2UV(cx->blk_sub.retop)); - break; + PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%" UVxf "\n", + PTR2UV(cx->blk_sub.cv)); + PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", + (long)cx->blk_sub.olddepth); + PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", + (int)CxHASARGS(cx)); + PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx)); + PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%" UVxf "\n", + PTR2UV(cx->blk_sub.retop)); + break; case CXt_EVAL: - PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n", - (long)CxOLD_IN_EVAL(cx)); - PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n", - PL_op_name[CxOLD_OP_TYPE(cx)], - PL_op_desc[CxOLD_OP_TYPE(cx)]); - if (cx->blk_eval.old_namesv) - PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n", - SvPVX_const(cx->blk_eval.old_namesv)); - PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%" UVxf "\n", - PTR2UV(cx->blk_eval.old_eval_root)); - PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%" UVxf "\n", - PTR2UV(cx->blk_eval.retop)); - break; + PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n", + (long)CxOLD_IN_EVAL(cx)); + PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n", + PL_op_name[CxOLD_OP_TYPE(cx)], + PL_op_desc[CxOLD_OP_TYPE(cx)]); + if (cx->blk_eval.old_namesv) + PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n", + SvPVX_const(cx->blk_eval.old_namesv)); + PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%" UVxf "\n", + PTR2UV(cx->blk_eval.old_eval_root)); + PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%" UVxf "\n", + PTR2UV(cx->blk_eval.retop)); + break; case CXt_LOOP_PLAIN: case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: case CXt_LOOP_LIST: case CXt_LOOP_ARY: - PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx)); - PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%" UVxf "\n", - PTR2UV(cx->blk_loop.my_op)); + PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx)); + PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%" UVxf "\n", + PTR2UV(cx->blk_loop.my_op)); if (CxTYPE(cx) != CXt_LOOP_PLAIN) { PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%" UVxf "\n", PTR2UV(CxITERVAR(cx))); PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%" UVxf "\n", PTR2UV(cx->blk_loop.itersave)); - } - if (CxTYPE(cx) == CXt_LOOP_ARY) { + } + if (CxTYPE(cx) == CXt_LOOP_ARY) { PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%" UVxf "\n", PTR2UV(cx->blk_loop.state_u.ary.ary)); PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n", (long)cx->blk_loop.state_u.ary.ix); } - break; + break; case CXt_SUBST: - PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n", - (long)cx->sb_iters); - PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n", - (long)cx->sb_maxiters); - PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n", - (long)cx->sb_rflags); - PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n", - (long)CxONCE(cx)); - PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n", - cx->sb_orig); - PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%" UVxf "\n", - PTR2UV(cx->sb_dstr)); - PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%" UVxf "\n", - PTR2UV(cx->sb_targ)); - PerlIO_printf(Perl_debug_log, "SB_S = 0x%" UVxf "\n", - PTR2UV(cx->sb_s)); - PerlIO_printf(Perl_debug_log, "SB_M = 0x%" UVxf "\n", - PTR2UV(cx->sb_m)); - PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%" UVxf "\n", - PTR2UV(cx->sb_strend)); - PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%" UVxf "\n", - PTR2UV(cx->sb_rxres)); - break; + PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n", + (long)cx->sb_iters); + PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n", + (long)cx->sb_maxiters); + PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n", + (long)cx->sb_rflags); + PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n", + (long)CxONCE(cx)); + PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n", + cx->sb_orig); + PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%" UVxf "\n", + PTR2UV(cx->sb_dstr)); + PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%" UVxf "\n", + PTR2UV(cx->sb_targ)); + PerlIO_printf(Perl_debug_log, "SB_S = 0x%" UVxf "\n", + PTR2UV(cx->sb_s)); + PerlIO_printf(Perl_debug_log, "SB_M = 0x%" UVxf "\n", + PTR2UV(cx->sb_m)); + PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%" UVxf "\n", + PTR2UV(cx->sb_strend)); + PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%" UVxf "\n", + PTR2UV(cx->sb_rxres)); + break; } #else PERL_UNUSED_CONTEXT; @@ -189,30 +189,30 @@ scope has the given name. C<name> must be a literal string. #ifdef DEBUGGING #define ENTER \ STMT_START { \ - push_scope(); \ - DEBUG_SCOPE("ENTER") \ + push_scope(); \ + DEBUG_SCOPE("ENTER") \ } STMT_END #define LEAVE \ STMT_START { \ - DEBUG_SCOPE("LEAVE") \ - pop_scope(); \ + DEBUG_SCOPE("LEAVE") \ + pop_scope(); \ } STMT_END #define ENTER_with_name(name) \ STMT_START { \ - push_scope(); \ - if (PL_scopestack_name) \ - PL_scopestack_name[PL_scopestack_ix-1] = name; \ - DEBUG_SCOPE("ENTER \"" name "\"") \ + push_scope(); \ + if (PL_scopestack_name) \ + PL_scopestack_name[PL_scopestack_ix-1] = name; \ + DEBUG_SCOPE("ENTER \"" name "\"") \ } STMT_END #define LEAVE_with_name(name) \ STMT_START { \ - DEBUG_SCOPE("LEAVE \"" name "\"") \ - if (PL_scopestack_name) { \ - assert(((char*)PL_scopestack_name[PL_scopestack_ix-1] \ - == (char*)name) \ - || strEQ(PL_scopestack_name[PL_scopestack_ix-1], name)); \ - } \ - pop_scope(); \ + DEBUG_SCOPE("LEAVE \"" name "\"") \ + if (PL_scopestack_name) { \ + assert(((char*)PL_scopestack_name[PL_scopestack_ix-1] \ + == (char*)name) \ + || strEQ(PL_scopestack_name[PL_scopestack_ix-1], name)); \ + } \ + pop_scope(); \ } STMT_END #else #define ENTER push_scope() @@ -221,7 +221,7 @@ scope has the given name. C<name> must be a literal string. #define LEAVE_with_name(name) LEAVE #endif #define LEAVE_SCOPE(old) STMT_START { \ - if (PL_savestack_ix > old) leave_scope(old); \ + if (PL_savestack_ix > old) leave_scope(old); \ } STMT_END #define SAVEI8(i) save_I8((I8*)&(i)) @@ -247,16 +247,16 @@ scope has the given name. C<name> must be a literal string. #define SAVESETSVFLAGS(sv,mask,val) save_set_svflags(sv,mask,val) #define SAVEFREECOPHH(h) save_pushptr((void *)(h), SAVEt_FREECOPHH) #define SAVEDELETE(h,k,l) \ - save_delete(MUTABLE_HV(h), (char*)(k), (I32)(l)) + save_delete(MUTABLE_HV(h), (char*)(k), (I32)(l)) #define SAVEHDELETE(h,s) \ - save_hdelete(MUTABLE_HV(h), (s)) + save_hdelete(MUTABLE_HV(h), (s)) #define SAVEADELETE(a,k) \ - save_adelete(MUTABLE_AV(a), (SSize_t)(k)) + save_adelete(MUTABLE_AV(a), (SSize_t)(k)) #define SAVEDESTRUCTOR(f,p) \ - save_destructor((DESTRUCTORFUNC_NOCONTEXT_t)(f), (void*)(p)) + save_destructor((DESTRUCTORFUNC_NOCONTEXT_t)(f), (void*)(p)) #define SAVEDESTRUCTOR_X(f,p) \ - save_destructor_x((DESTRUCTORFUNC_t)(f), (void*)(p)) + save_destructor_x((DESTRUCTORFUNC_t)(f), (void*)(p)) #define SAVESTACK_POS() \ STMT_START { \ @@ -274,9 +274,9 @@ scope has the given name. C<name> must be a literal string. #define SAVESWITCHSTACK(f,t) \ STMT_START { \ - save_pushptrptr(MUTABLE_SV(f), MUTABLE_SV(t), SAVEt_SAVESWITCHSTACK); \ - SWITCHSTACK((f),(t)); \ - PL_curstackinfo->si_stack = (t); \ + save_pushptrptr(MUTABLE_SV(f), MUTABLE_SV(t), SAVEt_SAVESWITCHSTACK); \ + SWITCHSTACK((f),(t)); \ + PL_curstackinfo->si_stack = (t); \ } STMT_END /* Need to do the cop warnings like this, rather than a "SAVEFREESHAREDPV", diff --git a/t/lib/h2ph.h b/t/lib/h2ph.h index 18804d55ba..9897bf2c07 100644 --- a/t/lib/h2ph.h +++ b/t/lib/h2ph.h @@ -91,7 +91,7 @@ typedef struct a_struct { */ typedef enum _days_of_week { sun, mon, tue, wed, thu, fri, sat, Sun=0, Mon, - Tue, Wed, Thu, Fri, Sat } days_of_week; + Tue, Wed, Thu, Fri, Sat } days_of_week; /* * Some moderate flexing of tri-graph pre substitution. @@ -103,11 +103,11 @@ typedef enum _days_of_week { sun, mon, tue, wed, thu, fri, sat, Sun=0, Mon, ??= define SOMETHING_ELSE_TRIGRAPHIC_2 "??(" /* | ??(| [| */ ??= define SOMETHING_ELSE_TRIGRAPHIC_3 "??)" /* | ??)| ]| */ ??=define SOMETHING_ELSE_TRIGRAPHIC_4 "??-0" /* | ??-| ~| */ - ??= define SOMETHING_ELSE_TRIGRAPHIC_5 "??/ " /* | ??/| \| */ + ??= define SOMETHING_ELSE_TRIGRAPHIC_5 "??/ " /* | ??/| \| */ ??= define SOMETHING_ELSE_TRIGRAPHIC_6 "??<" /* | ??<| {| */ ??=define SOMETHING_ELSE_TRIGRAPHIC_7 "??=" /* | ??=| #| */ ??= define SOMETHING_ELSE_TRIGRAPHIC_8 "??>" /* | ??>| }| */ - ??=endif + ??=endif // test C++-style comment @@ -33,15 +33,15 @@ Perl_taint_proper(pTHX_ const char *f, const char *const s) PERL_ARGS_ASSERT_TAINT_PROPER; { - const Uid_t uid = PerlProc_getuid(); - const Uid_t euid = PerlProc_geteuid(); + const Uid_t uid = PerlProc_getuid(); + const Uid_t euid = PerlProc_geteuid(); #if Uid_t_sign == 1 /* uid_t is unsigned. */ - DEBUG_u(PerlIO_printf(Perl_debug_log, + DEBUG_u(PerlIO_printf(Perl_debug_log, "%s %d %" UVuf " %" UVuf "\n", s, TAINT_get, (UV)uid, (UV)euid)); #else /* uid_t is signed (Uid_t_sign == -1), or don't know. */ - DEBUG_u(PerlIO_printf(Perl_debug_log, + DEBUG_u(PerlIO_printf(Perl_debug_log, "%s %d %" IVdf " %" IVdf "\n", s, TAINT_get, (IV)uid, (IV)euid)); #endif @@ -49,25 +49,25 @@ Perl_taint_proper(pTHX_ const char *f, const char *const s) #endif if (TAINT_get) { - const char *ug; - - if (!f) - f = PL_no_security; - if (PerlProc_getuid() != PerlProc_geteuid()) - ug = " while running setuid"; - else if (PerlProc_getgid() != PerlProc_getegid()) - ug = " while running setgid"; - else if (TAINT_WARN_get) + const char *ug; + + if (!f) + f = PL_no_security; + if (PerlProc_getuid() != PerlProc_geteuid()) + ug = " while running setuid"; + else if (PerlProc_getgid() != PerlProc_getegid()) + ug = " while running setgid"; + else if (TAINT_WARN_get) ug = " while running with -t switch"; else - ug = " while running with -T switch"; + ug = " while running with -T switch"; /* XXX because taint_proper adds extra format args, we can't * get the caller to check properly; so we just silence the warning * and hope the callers aren't naughty */ GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); - if (PL_unsafe || TAINT_WARN_get) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_TAINT), f, s, ug); + if (PL_unsafe || TAINT_WARN_get) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_TAINT), f, s, ug); } else { Perl_croak(aTHX_ f, s, ug); @@ -83,34 +83,34 @@ Perl_taint_env(pTHX) SV** svp; const char* const *e; static const char* const misc_env[] = { - "IFS", /* most shells' inter-field separators */ - "CDPATH", /* ksh dain bramage #1 */ - "ENV", /* ksh dain bramage #2 */ - "BASH_ENV", /* bash dain bramage -- I guess it's contagious */ + "IFS", /* most shells' inter-field separators */ + "CDPATH", /* ksh dain bramage #1 */ + "ENV", /* ksh dain bramage #2 */ + "BASH_ENV", /* bash dain bramage -- I guess it's contagious */ #ifdef WIN32 - "PERL5SHELL", /* used for system() on Windows */ + "PERL5SHELL", /* used for system() on Windows */ #endif - NULL + NULL }; /* Don't bother if there's no *ENV glob */ if (!PL_envgv) - return; + return; /* If there's no %ENV hash or if it's not magical, croak, because * it probably doesn't reflect the actual environment */ if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv)) - && mg_find((const SV *)GvHV(PL_envgv), PERL_MAGIC_env))) { - const bool was_tainted = TAINT_get; - const char * const name = GvENAME(PL_envgv); - TAINT; - if (strEQ(name,"ENV")) - /* hash alias */ - taint_proper("%%ENV is aliased to %s%s", "another variable"); - else - /* glob alias: report it in the error message */ - taint_proper("%%ENV is aliased to %%%s%s", name); - /* this statement is reached under -t or -U */ - TAINT_set(was_tainted); + && mg_find((const SV *)GvHV(PL_envgv), PERL_MAGIC_env))) { + const bool was_tainted = TAINT_get; + const char * const name = GvENAME(PL_envgv); + TAINT; + if (strEQ(name,"ENV")) + /* hash alias */ + taint_proper("%%ENV is aliased to %s%s", "another variable"); + else + /* glob alias: report it in the error message */ + taint_proper("%%ENV is aliased to %%%s%s", name); + /* this statement is reached under -t or -U */ + TAINT_set(was_tainted); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(was_tainted); #endif @@ -124,20 +124,20 @@ Perl_taint_env(pTHX) while (1) { MAGIC* mg; - if (i) - len = my_snprintf(name, sizeof name, "DCL$PATH;%d", i); - svp = hv_fetch(GvHVn(PL_envgv), name, len, FALSE); - if (!svp || *svp == &PL_sv_undef) - break; - if (SvTAINTED(*svp)) { - TAINT; - taint_proper("Insecure %s%s", "$ENV{DCL$PATH}"); - } - if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) { - TAINT; - taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}"); - } - i++; + if (i) + len = my_snprintf(name, sizeof name, "DCL$PATH;%d", i); + svp = hv_fetch(GvHVn(PL_envgv), name, len, FALSE); + if (!svp || *svp == &PL_sv_undef) + break; + if (SvTAINTED(*svp)) { + TAINT; + taint_proper("Insecure %s%s", "$ENV{DCL$PATH}"); + } + if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) { + TAINT; + taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}"); + } + i++; } } #endif /* VMS */ @@ -145,46 +145,46 @@ Perl_taint_env(pTHX) svp = hv_fetchs(GvHVn(PL_envgv),"PATH",FALSE); if (svp && *svp) { MAGIC* mg; - if (SvTAINTED(*svp)) { - TAINT; - taint_proper("Insecure %s%s", "$ENV{PATH}"); - } - if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) { - TAINT; - taint_proper("Insecure directory in %s%s", "$ENV{PATH}"); - } + if (SvTAINTED(*svp)) { + TAINT; + taint_proper("Insecure %s%s", "$ENV{PATH}"); + } + if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) { + TAINT; + taint_proper("Insecure directory in %s%s", "$ENV{PATH}"); + } } #ifndef VMS /* tainted $TERM is okay if it contains no metachars */ svp = hv_fetchs(GvHVn(PL_envgv),"TERM",FALSE); if (svp && *svp && SvTAINTED(*svp)) { - STRLEN len; - const bool was_tainted = TAINT_get; - const char *t = SvPV_const(*svp, len); - const char * const e = t + len; + STRLEN len; + const bool was_tainted = TAINT_get; + const char *t = SvPV_const(*svp, len); + const char * const e = t + len; - TAINT_set(was_tainted); + TAINT_set(was_tainted); #ifdef NO_TAINT_SUPPORT PERL_UNUSED_VAR(was_tainted); #endif - if (t < e && isWORDCHAR(*t)) - t++; - while (t < e && (isWORDCHAR(*t) || memCHRs("-_.+", *t))) - t++; - if (t < e) { - TAINT; - taint_proper("Insecure $ENV{%s}%s", "TERM"); - } + if (t < e && isWORDCHAR(*t)) + t++; + while (t < e && (isWORDCHAR(*t) || memCHRs("-_.+", *t))) + t++; + if (t < e) { + TAINT; + taint_proper("Insecure $ENV{%s}%s", "TERM"); + } } #endif /* !VMS */ for (e = misc_env; *e; e++) { - SV * const * const svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE); - if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) { - TAINT; - taint_proper("Insecure $ENV{%s}%s", *e); - } + SV * const * const svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE); + if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) { + TAINT; + taint_proper("Insecure $ENV{%s}%s", *e); + } } } @@ -22,12 +22,12 @@ # ifdef OLD_PTHREADS_API /* Here be dragons. */ # define DETACH(t) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = pthread_detach(&(t)->self))) { \ - MUTEX_UNLOCK(&(t)->mutex); \ - Perl_croak_nocontext("panic: DETACH (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ - } \ + int _eC_; \ + if ((_eC_ = pthread_detach(&(t)->self))) { \ + MUTEX_UNLOCK(&(t)->mutex); \ + Perl_croak_nocontext("panic: DETACH (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ + } \ } STMT_END # define PERL_GET_CONTEXT Perl_get_context() @@ -106,33 +106,33 @@ #define MUTEX_INIT(m) \ STMT_START { \ - *m = mutex_alloc(); \ - if (*m) { \ - mutex_init(*m); \ - } else { \ - Perl_croak_nocontext("panic: MUTEX_INIT [%s:%d]", \ - __FILE__, __LINE__); \ - } \ + *m = mutex_alloc(); \ + if (*m) { \ + mutex_init(*m); \ + } else { \ + Perl_croak_nocontext("panic: MUTEX_INIT [%s:%d]", \ + __FILE__, __LINE__); \ + } \ } STMT_END #define MUTEX_LOCK(m) mutex_lock(*m) #define MUTEX_UNLOCK(m) mutex_unlock(*m) #define MUTEX_DESTROY(m) \ STMT_START { \ - mutex_free(*m); \ - *m = 0; \ + mutex_free(*m); \ + *m = 0; \ } STMT_END #define COND_INIT(c) \ STMT_START { \ - *c = condition_alloc(); \ - if (*c) { \ - condition_init(*c); \ - } \ - else { \ - Perl_croak_nocontext("panic: COND_INIT [%s:%d]", \ - __FILE__, __LINE__); \ - } \ + *c = condition_alloc(); \ + if (*c) { \ + condition_init(*c); \ + } \ + else { \ + Perl_croak_nocontext("panic: COND_INIT [%s:%d]", \ + __FILE__, __LINE__); \ + } \ } STMT_END #define COND_SIGNAL(c) condition_signal(*c) @@ -140,8 +140,8 @@ #define COND_WAIT(c, m) condition_wait(*c, *m) #define COND_DESTROY(c) \ STMT_START { \ - condition_free(*c); \ - *c = 0; \ + condition_free(*c); \ + *c = 0; \ } STMT_END #define THREAD_RET_TYPE any_t @@ -182,19 +182,19 @@ /* Temporary workaround, true bug is deeper. --jhi 1999-02-25 */ # define MUTEX_INIT(m) \ STMT_START { \ - int _eC_; \ - Zero((m), 1, perl_mutex); \ - if ((_eC_ = pthread_mutex_init((m), pthread_mutexattr_default))) \ - Perl_croak_nocontext("panic: MUTEX_INIT (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + Zero((m), 1, perl_mutex); \ + if ((_eC_ = pthread_mutex_init((m), pthread_mutexattr_default))) \ + Perl_croak_nocontext("panic: MUTEX_INIT (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END # else # define MUTEX_INIT(m) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = pthread_mutex_init((m), pthread_mutexattr_default))) \ - Perl_croak_nocontext("panic: MUTEX_INIT (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + if ((_eC_ = pthread_mutex_init((m), pthread_mutexattr_default))) \ + Perl_croak_nocontext("panic: MUTEX_INIT (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END # endif @@ -208,68 +208,68 @@ # define MUTEX_LOCK(m) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = perl_pthread_mutex_lock((m)))) \ - Perl_croak_nocontext("panic: MUTEX_LOCK (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + if ((_eC_ = perl_pthread_mutex_lock((m)))) \ + Perl_croak_nocontext("panic: MUTEX_LOCK (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END # define MUTEX_UNLOCK(m) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = perl_pthread_mutex_unlock((m)))) \ - Perl_croak_nocontext("panic: MUTEX_UNLOCK (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + if ((_eC_ = perl_pthread_mutex_unlock((m)))) \ + Perl_croak_nocontext("panic: MUTEX_UNLOCK (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END # define MUTEX_DESTROY(m) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = pthread_mutex_destroy((m)))) \ - Perl_croak_nocontext("panic: MUTEX_DESTROY (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + if ((_eC_ = pthread_mutex_destroy((m)))) \ + Perl_croak_nocontext("panic: MUTEX_DESTROY (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END #endif /* MUTEX_INIT */ #ifndef COND_INIT # define COND_INIT(c) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = pthread_cond_init((c), pthread_condattr_default))) \ - Perl_croak_nocontext("panic: COND_INIT (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + if ((_eC_ = pthread_cond_init((c), pthread_condattr_default))) \ + Perl_croak_nocontext("panic: COND_INIT (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END # define COND_SIGNAL(c) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = pthread_cond_signal((c)))) \ - Perl_croak_nocontext("panic: COND_SIGNAL (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + if ((_eC_ = pthread_cond_signal((c)))) \ + Perl_croak_nocontext("panic: COND_SIGNAL (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END # define COND_BROADCAST(c) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = pthread_cond_broadcast((c)))) \ - Perl_croak_nocontext("panic: COND_BROADCAST (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + if ((_eC_ = pthread_cond_broadcast((c)))) \ + Perl_croak_nocontext("panic: COND_BROADCAST (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END # define COND_WAIT(c, m) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = pthread_cond_wait((c), (m)))) \ - Perl_croak_nocontext("panic: COND_WAIT (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + if ((_eC_ = pthread_cond_wait((c), (m)))) \ + Perl_croak_nocontext("panic: COND_WAIT (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END # define COND_DESTROY(c) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = pthread_cond_destroy((c)))) \ - Perl_croak_nocontext("panic: COND_DESTROY (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + if ((_eC_ = pthread_cond_destroy((c)))) \ + Perl_croak_nocontext("panic: COND_DESTROY (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END #endif /* COND_INIT */ @@ -346,22 +346,22 @@ #ifndef DETACH # define DETACH(t) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = pthread_detach((t)->self))) { \ - MUTEX_UNLOCK(&(t)->mutex); \ - Perl_croak_nocontext("panic: DETACH (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ - } \ + int _eC_; \ + if ((_eC_ = pthread_detach((t)->self))) { \ + MUTEX_UNLOCK(&(t)->mutex); \ + Perl_croak_nocontext("panic: DETACH (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ + } \ } STMT_END #endif /* DETACH */ #ifndef JOIN # define JOIN(t, avp) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = pthread_join((t)->self, (void**)(avp)))) \ - Perl_croak_nocontext("panic: pthread_join (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + if ((_eC_ = pthread_join((t)->self, (void**)(avp)))) \ + Perl_croak_nocontext("panic: pthread_join (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END #endif /* JOIN */ @@ -386,10 +386,10 @@ #ifndef PERL_SET_CONTEXT # define PERL_SET_CONTEXT(t) \ STMT_START { \ - int _eC_; \ - if ((_eC_ = pthread_setspecific(PL_thr_key, (void *)(t)))) \ - Perl_croak_nocontext("panic: pthread_setspecific (%d) [%s:%d]", \ - _eC_, __FILE__, __LINE__); \ + int _eC_; \ + if ((_eC_ = pthread_setspecific(PL_thr_key, (void *)(t)))) \ + Perl_croak_nocontext("panic: pthread_setspecific (%d) [%s:%d]", \ + _eC_, __FILE__, __LINE__); \ } STMT_END #endif /* PERL_SET_CONTEXT */ @@ -402,27 +402,27 @@ #ifndef ALLOC_THREAD_KEY # define ALLOC_THREAD_KEY \ STMT_START { \ - if (pthread_key_create(&PL_thr_key, 0)) { \ + if (pthread_key_create(&PL_thr_key, 0)) { \ PERL_UNUSED_RESULT(write(2, STR_WITH_LEN("panic: pthread_key_create failed\n"))); \ - exit(1); \ - } \ + exit(1); \ + } \ } STMT_END #endif #ifndef FREE_THREAD_KEY # define FREE_THREAD_KEY \ STMT_START { \ - pthread_key_delete(PL_thr_key); \ + pthread_key_delete(PL_thr_key); \ } STMT_END #endif #ifndef PTHREAD_ATFORK # ifdef HAS_PTHREAD_ATFORK # define PTHREAD_ATFORK(prepare,parent,child) \ - pthread_atfork(prepare,parent,child) + pthread_atfork(prepare,parent,child) # else # define PTHREAD_ATFORK(prepare,parent,child) \ - NOOP + NOOP # endif #endif diff --git a/universal.c b/universal.c index 9c49cd8327..c459064a6c 100644 --- a/universal.c +++ b/universal.c @@ -53,14 +53,14 @@ S_isa_lookup(pTHX_ HV *stash, SV *namesv, const char * name, STRLEN len, U32 fla PERL_ARGS_ASSERT_ISA_LOOKUP; if (!isa) { - (void)mro_get_linear_isa(stash); - isa = meta->isa; + (void)mro_get_linear_isa(stash); + isa = meta->isa; } if (hv_common(isa, namesv, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0), - HV_FETCH_ISEXISTS, NULL, 0)) { - /* Direct name lookup worked. */ - return TRUE; + HV_FETCH_ISEXISTS, NULL, 0)) { + /* Direct name lookup worked. */ + return TRUE; } /* A stash/class can go by many names (ie. User == main::User), so @@ -69,14 +69,14 @@ S_isa_lookup(pTHX_ HV *stash, SV *namesv, const char * name, STRLEN len, U32 fla our_stash = gv_stashsvpvn_cached(namesv, name, len, flags); if (our_stash) { - HEK *canon_name = HvENAME_HEK(our_stash); - if (!canon_name) canon_name = HvNAME_HEK(our_stash); - assert(canon_name); - if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name), - HEK_FLAGS(canon_name), - HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) { - return TRUE; - } + HEK *canon_name = HvENAME_HEK(our_stash); + if (!canon_name) canon_name = HvNAME_HEK(our_stash); + assert(canon_name); + if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name), + HEK_FLAGS(canon_name), + HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) { + return TRUE; + } } return FALSE; @@ -285,19 +285,19 @@ Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) SvGETMAGIC(sv); if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) { - LEAVE; - return FALSE; + LEAVE; + return FALSE; } if (SvROK(sv) && SvOBJECT(SvRV(sv))) { - classname = sv_ref(NULL,SvRV(sv),TRUE); + classname = sv_ref(NULL,SvRV(sv),TRUE); } else { - classname = sv; + classname = sv; } if (sv_eq(classname, namesv)) { - LEAVE; - return TRUE; + LEAVE; + return TRUE; } PUSHMARK(SP); @@ -396,25 +396,25 @@ Perl_croak_xs_usage(const CV *const cv, const char *const params) PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) got_gv: { - const HV *const stash = GvSTASH(gv); + const HV *const stash = GvSTASH(gv); - if (HvNAME_get(stash)) - /* diag_listed_as: SKIPME */ - Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)", + if (HvNAME_get(stash)) + /* diag_listed_as: SKIPME */ + Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)", HEKfARG(HvNAME_HEK(stash)), HEKfARG(GvNAME_HEK(gv)), params); - else - /* diag_listed_as: SKIPME */ - Perl_croak_nocontext("Usage: %" HEKf "(%s)", + else + /* diag_listed_as: SKIPME */ + Perl_croak_nocontext("Usage: %" HEKf "(%s)", HEKfARG(GvNAME_HEK(gv)), params); } else { dTHX; if ((gv = CvGV(cv))) goto got_gv; - /* Pants. I don't think that it should be possible to get here. */ - /* diag_listed_as: SKIPME */ - Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); + /* Pants. I don't think that it should be possible to get here. */ + /* diag_listed_as: SKIPME */ + Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); } } @@ -424,17 +424,17 @@ XS(XS_UNIVERSAL_isa) dXSARGS; if (items != 2) - croak_xs_usage(cv, "reference, kind"); + croak_xs_usage(cv, "reference, kind"); else { - SV * const sv = ST(0); + SV * const sv = ST(0); - SvGETMAGIC(sv); + SvGETMAGIC(sv); - if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) - XSRETURN_UNDEF; + if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) + XSRETURN_UNDEF; - ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0)); - XSRETURN(1); + ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0)); + XSRETURN(1); } } @@ -448,7 +448,7 @@ XS(XS_UNIVERSAL_can) GV *iogv; if (items != 2) - croak_xs_usage(cv, "object-ref, method"); + croak_xs_usage(cv, "object-ref, method"); sv = ST(0); @@ -458,7 +458,7 @@ XS(XS_UNIVERSAL_can) precedence here over the numeric form, as (!1)->foo treats the invocant as the empty string, though it is a dualvar. */ if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv))) - XSRETURN_UNDEF; + XSRETURN_UNDEF; rv = &PL_sv_undef; @@ -467,7 +467,7 @@ XS(XS_UNIVERSAL_can) if (SvOBJECT(sv)) pkg = SvSTASH(sv); else if (isGV_with_GP(sv) && GvIO(sv)) - pkg = SvSTASH(GvIO(sv)); + pkg = SvSTASH(GvIO(sv)); } else if (isGV_with_GP(sv) && GvIO(sv)) pkg = SvSTASH(GvIO(sv)); @@ -480,9 +480,9 @@ XS(XS_UNIVERSAL_can) } if (pkg) { - GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0); + GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0); if (gv && isGV(gv)) - rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); + rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); } ST(0) = rv; @@ -496,13 +496,13 @@ XS(XS_UNIVERSAL_DOES) PERL_UNUSED_ARG(cv); if (items != 2) - Perl_croak(aTHX_ "Usage: invocant->DOES(kind)"); + Perl_croak(aTHX_ "Usage: invocant->DOES(kind)"); else { - SV * const sv = ST(0); - if (sv_does_sv( sv, ST(1), 0 )) - XSRETURN_YES; + SV * const sv = ST(0); + if (sv_does_sv( sv, ST(1), 0 )) + XSRETURN_YES; - XSRETURN_NO; + XSRETURN_NO; } } @@ -511,14 +511,14 @@ XS(XS_utf8_is_utf8) { dXSARGS; if (items != 1) - croak_xs_usage(cv, "sv"); + croak_xs_usage(cv, "sv"); else { - SV * const sv = ST(0); - SvGETMAGIC(sv); - if (SvUTF8(sv)) - XSRETURN_YES; - else - XSRETURN_NO; + SV * const sv = ST(0); + SvGETMAGIC(sv); + if (SvUTF8(sv)) + XSRETURN_YES; + else + XSRETURN_NO; } XSRETURN_EMPTY; } @@ -528,15 +528,15 @@ XS(XS_utf8_valid) { dXSARGS; if (items != 1) - croak_xs_usage(cv, "sv"); + croak_xs_usage(cv, "sv"); else { - SV * const sv = ST(0); - STRLEN len; - const char * const s = SvPV_const(sv,len); - if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) - XSRETURN_YES; - else - XSRETURN_NO; + SV * const sv = ST(0); + STRLEN len; + const char * const s = SvPV_const(sv,len); + if (!SvUTF8(sv) || is_utf8_string((const U8*)s,len)) + XSRETURN_YES; + else + XSRETURN_NO; } XSRETURN_EMPTY; } @@ -546,7 +546,7 @@ XS(XS_utf8_encode) { dXSARGS; if (items != 1) - croak_xs_usage(cv, "sv"); + croak_xs_usage(cv, "sv"); sv_utf8_encode(ST(0)); SvSETMAGIC(ST(0)); XSRETURN_EMPTY; @@ -557,14 +557,14 @@ XS(XS_utf8_decode) { dXSARGS; if (items != 1) - croak_xs_usage(cv, "sv"); + croak_xs_usage(cv, "sv"); else { - SV * const sv = ST(0); - bool RETVAL; - SvPV_force_nolen(sv); - RETVAL = sv_utf8_decode(sv); - SvSETMAGIC(sv); - ST(0) = boolSV(RETVAL); + SV * const sv = ST(0); + bool RETVAL; + SvPV_force_nolen(sv); + RETVAL = sv_utf8_decode(sv); + SvSETMAGIC(sv); + ST(0) = boolSV(RETVAL); } XSRETURN(1); } @@ -574,14 +574,14 @@ XS(XS_utf8_upgrade) { dXSARGS; if (items != 1) - croak_xs_usage(cv, "sv"); + croak_xs_usage(cv, "sv"); else { - SV * const sv = ST(0); - STRLEN RETVAL; - dXSTARG; + SV * const sv = ST(0); + STRLEN RETVAL; + dXSTARG; - RETVAL = sv_utf8_upgrade(sv); - XSprePUSH; PUSHi((IV)RETVAL); + RETVAL = sv_utf8_upgrade(sv); + XSprePUSH; PUSHi((IV)RETVAL); } XSRETURN(1); } @@ -591,14 +591,14 @@ XS(XS_utf8_downgrade) { dXSARGS; if (items < 1 || items > 2) - croak_xs_usage(cv, "sv, failok=0"); + croak_xs_usage(cv, "sv, failok=0"); else { - SV * const sv0 = ST(0); - SV * const sv1 = ST(1); + SV * const sv0 = ST(0); + SV * const sv1 = ST(1); const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0; const bool RETVAL = sv_utf8_downgrade(sv0, failok); - ST(0) = boolSV(RETVAL); + ST(0) = boolSV(RETVAL); } XSRETURN(1); } @@ -643,22 +643,22 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ sv = SvRV(svz); if (items == 1) { - if (SvREADONLY(sv)) - XSRETURN_YES; - else - XSRETURN_NO; + if (SvREADONLY(sv)) + XSRETURN_YES; + else + XSRETURN_NO; } else if (items == 2) { SV *sv1 = ST(1); - if (SvTRUE_NN(sv1)) { - SvFLAGS(sv) |= SVf_READONLY; - XSRETURN_YES; - } - else { - /* I hope you really know what you are doing. */ - SvFLAGS(sv) &=~ SVf_READONLY; - XSRETURN_NO; - } + if (SvTRUE_NN(sv1)) { + SvFLAGS(sv) |= SVf_READONLY; + XSRETURN_YES; + } + else { + /* I hope you really know what you are doing. */ + SvFLAGS(sv) &=~ SVf_READONLY; + XSRETURN_NO; + } } XSRETURN_UNDEF; /* Can't happen. */ } @@ -678,13 +678,13 @@ XS(XS_constant__make_const) /* This is dangerous stuff. */ SvREADONLY_on(sv); if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) { - /* for constant.pm; nobody else should be calling this - on arrays anyway. */ - SV **svp; - for (svp = AvARRAY(sv) + AvFILLp(sv) - ; svp >= AvARRAY(sv) - ; --svp) - if (*svp) SvPADTMP_on(*svp); + /* for constant.pm; nobody else should be calling this + on arrays anyway. */ + SV **svp; + for (svp = AvARRAY(sv) + AvFILLp(sv) + ; svp >= AvARRAY(sv) + ; --svp) + if (*svp) SvPADTMP_on(*svp); } XSRETURN(0); } @@ -719,11 +719,11 @@ XS(XS_Internals_hv_clear_placehold) dXSARGS; if (items != 1 || !SvROK(ST(0))) - croak_xs_usage(cv, "hv"); + croak_xs_usage(cv, "hv"); else { - HV * const hv = MUTABLE_HV(SvRV(ST(0))); - hv_clear_placeholders(hv); - XSRETURN(0); + HV * const hv = MUTABLE_HV(SvRV(ST(0))); + hv_clear_placeholders(hv); + XSRETURN(0); } } @@ -732,120 +732,120 @@ XS(XS_PerlIO_get_layers) { dXSARGS; if (items < 1 || items % 2 == 0) - croak_xs_usage(cv, "filehandle[,args]"); + croak_xs_usage(cv, "filehandle[,args]"); #if defined(USE_PERLIO) { - SV * sv; - GV * gv; - IO * io; - bool input = TRUE; - bool details = FALSE; - - if (items > 1) { - SV * const *svp; - for (svp = MARK + 2; svp <= SP; svp += 2) { - SV * const * const varp = svp; - SV * const * const valp = svp + 1; - STRLEN klen; - const char * const key = SvPV_const(*varp, klen); - - switch (*key) { - case 'i': + SV * sv; + GV * gv; + IO * io; + bool input = TRUE; + bool details = FALSE; + + if (items > 1) { + SV * const *svp; + for (svp = MARK + 2; svp <= SP; svp += 2) { + SV * const * const varp = svp; + SV * const * const valp = svp + 1; + STRLEN klen; + const char * const key = SvPV_const(*varp, klen); + + switch (*key) { + case 'i': if (memEQs(key, klen, "input")) { - input = SvTRUE(*valp); - break; - } - goto fail; - case 'o': + input = SvTRUE(*valp); + break; + } + goto fail; + case 'o': if (memEQs(key, klen, "output")) { - input = !SvTRUE(*valp); - break; - } - goto fail; - case 'd': + input = !SvTRUE(*valp); + break; + } + goto fail; + case 'd': if (memEQs(key, klen, "details")) { - details = SvTRUE(*valp); - break; - } - goto fail; - default: - fail: - Perl_croak(aTHX_ - "get_layers: unknown argument '%s'", - key); - } - } - - SP -= (items - 1); - } - - sv = POPs; - gv = MAYBE_DEREF_GV(sv); - - if (!gv && !SvROK(sv)) - gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); - - if (gv && (io = GvIO(gv))) { - AV* const av = PerlIO_get_layers(aTHX_ input ? - IoIFP(io) : IoOFP(io)); - SSize_t i; - const SSize_t last = av_top_index(av); - SSize_t nitem = 0; - - for (i = last; i >= 0; i -= 3) { - SV * const * const namsvp = av_fetch(av, i - 2, FALSE); - SV * const * const argsvp = av_fetch(av, i - 1, FALSE); - SV * const * const flgsvp = av_fetch(av, i, FALSE); - - const bool namok = namsvp && *namsvp && SvPOK(*namsvp); - const bool argok = argsvp && *argsvp && SvPOK(*argsvp); - const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); - - EXTEND(SP, 3); /* Three is the max in all branches: better check just once */ - if (details) { - /* Indents of 5? Yuck. */ - /* We know that PerlIO_get_layers creates a new SV for - the name and flags, so we can just take a reference - and "steal" it when we free the AV below. */ - PUSHs(namok - ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)) - : &PL_sv_undef); - PUSHs(argok - ? newSVpvn_flags(SvPVX_const(*argsvp), - SvCUR(*argsvp), - (SvUTF8(*argsvp) ? SVf_UTF8 : 0) - | SVs_TEMP) - : &PL_sv_undef); - PUSHs(flgok - ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp)) - : &PL_sv_undef); - nitem += 3; - } - else { - if (namok && argok) - PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")", - SVfARG(*namsvp), - SVfARG(*argsvp)))); - else if (namok) - PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))); - else - PUSHs(&PL_sv_undef); - nitem++; - if (flgok) { - const IV flags = SvIVX(*flgsvp); - - if (flags & PERLIO_F_UTF8) { - PUSHs(newSVpvs_flags("utf8", SVs_TEMP)); - nitem++; - } - } - } - } - - SvREFCNT_dec(av); - - XSRETURN(nitem); - } + details = SvTRUE(*valp); + break; + } + goto fail; + default: + fail: + Perl_croak(aTHX_ + "get_layers: unknown argument '%s'", + key); + } + } + + SP -= (items - 1); + } + + sv = POPs; + gv = MAYBE_DEREF_GV(sv); + + if (!gv && !SvROK(sv)) + gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); + + if (gv && (io = GvIO(gv))) { + AV* const av = PerlIO_get_layers(aTHX_ input ? + IoIFP(io) : IoOFP(io)); + SSize_t i; + const SSize_t last = av_top_index(av); + SSize_t nitem = 0; + + for (i = last; i >= 0; i -= 3) { + SV * const * const namsvp = av_fetch(av, i - 2, FALSE); + SV * const * const argsvp = av_fetch(av, i - 1, FALSE); + SV * const * const flgsvp = av_fetch(av, i, FALSE); + + const bool namok = namsvp && *namsvp && SvPOK(*namsvp); + const bool argok = argsvp && *argsvp && SvPOK(*argsvp); + const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); + + EXTEND(SP, 3); /* Three is the max in all branches: better check just once */ + if (details) { + /* Indents of 5? Yuck. */ + /* We know that PerlIO_get_layers creates a new SV for + the name and flags, so we can just take a reference + and "steal" it when we free the AV below. */ + PUSHs(namok + ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)) + : &PL_sv_undef); + PUSHs(argok + ? newSVpvn_flags(SvPVX_const(*argsvp), + SvCUR(*argsvp), + (SvUTF8(*argsvp) ? SVf_UTF8 : 0) + | SVs_TEMP) + : &PL_sv_undef); + PUSHs(flgok + ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp)) + : &PL_sv_undef); + nitem += 3; + } + else { + if (namok && argok) + PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")", + SVfARG(*namsvp), + SVfARG(*argsvp)))); + else if (namok) + PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))); + else + PUSHs(&PL_sv_undef); + nitem++; + if (flgok) { + const IV flags = SvIVX(*flgsvp); + + if (flags & PERLIO_F_UTF8) { + PUSHs(newSVpvs_flags("utf8", SVs_TEMP)); + nitem++; + } + } + } + } + + SvREFCNT_dec(av); + + XSRETURN(nitem); + } } #endif @@ -858,7 +858,7 @@ XS(XS_re_is_regexp) dXSARGS; if (items != 1) - croak_xs_usage(cv, "sv"); + croak_xs_usage(cv, "sv"); if (SvRXOK(ST(0))) { XSRETURN_YES; @@ -875,7 +875,7 @@ XS(XS_re_regnames_count) dXSARGS; if (items != 0) - croak_xs_usage(cv, ""); + croak_xs_usage(cv, ""); if (!rx) XSRETURN_UNDEF; @@ -896,7 +896,7 @@ XS(XS_re_regname) SV * ret; if (items < 1 || items > 2) - croak_xs_usage(cv, "name[, all ]"); + croak_xs_usage(cv, "name[, all ]"); SP -= items; PUTBACK; @@ -932,7 +932,7 @@ XS(XS_re_regnames) SV **entry; if (items > 1) - croak_xs_usage(cv, "[all]"); + croak_xs_usage(cv, "[all]"); rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; @@ -984,7 +984,7 @@ XS(XS_re_regexp_pattern) EXTEND(SP, 2); SP -= items; if (items != 1) - croak_xs_usage(cv, "sv"); + croak_xs_usage(cv, "sv"); /* Checks if a reference is a regex or not. If the parameter is @@ -1003,8 +1003,8 @@ XS(XS_re_regexp_pattern) SV *pattern; if ( gimme == G_ARRAY ) { - STRLEN left = 0; - char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH]; + STRLEN left = 0; + char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH]; const char *fptr; char ch; U16 match_flags; @@ -1015,13 +1015,13 @@ XS(XS_re_regexp_pattern) modifiers" in this scenario, and the default character set */ - if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) { - STRLEN len; - const char* const name = get_regex_charset_name(RX_EXTFLAGS(re), - &len); - Copy(name, reflags + left, len, char); - left += len; - } + if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) { + STRLEN len; + const char* const name = get_regex_charset_name(RX_EXTFLAGS(re), + &len); + Copy(name, reflags + left, len, char); + left += len; + } fptr = INT_PAT_MODS; match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME) >> RXf_PMf_STD_PMMOD_SHIFT); @@ -1034,7 +1034,7 @@ XS(XS_re_regexp_pattern) } pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re), - (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); + (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); /* return the pattern and the modifiers */ PUSHs(pattern); @@ -1121,18 +1121,18 @@ XS(XS_NamedCapture_TIEHASH) if (items < 1) croak_xs_usage(cv, "package, ..."); { - const char * package = (const char *)SvPV_nolen(ST(0)); - UV flag = RXapif_ONE; - mark += 2; - while(mark < sp) { - STRLEN len; - const char *p = SvPV_const(*mark, len); - if(memEQs(p, len, "all")) - flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE; - mark += 2; - } - ST(0) = sv_2mortal(newSV_type(SVt_IV)); - sv_setuv(newSVrv(ST(0), package), flag); + const char * package = (const char *)SvPV_nolen(ST(0)); + UV flag = RXapif_ONE; + mark += 2; + while(mark < sp) { + STRLEN len; + const char *p = SvPV_const(*mark, len); + if(memEQs(p, len, "all")) + flag = SvTRUE(mark[1]) ? RXapif_ALL : RXapif_ONE; + mark += 2; + } + ST(0) = sv_2mortal(newSV_type(SVt_IV)); + sv_setuv(newSVrv(ST(0), package), flag); } XSRETURN(1); } @@ -1158,39 +1158,39 @@ XS(XS_NamedCapture_FETCH) PERL_UNUSED_VAR(ax); /* -Wall */ SP -= items; { - REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - U32 flags; - SV *ret; - const U32 action = ix & ACTION_MASK; - const int expect = ix >> EXPECT_SHIFT; - if (items != expect) - croak_xs_usage(cv, expect == 2 ? "$key" - : (expect == 3 ? "$key, $value" - : "")); - - if (!rx || !SvROK(ST(0))) { - if (ix & UNDEF_FATAL) - Perl_croak_no_modify(); - else - XSRETURN_UNDEF; - } - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - - PUTBACK; - ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL, - expect >= 3 ? ST(2) : NULL, flags | action); - SPAGAIN; - - if (ix & DISCARD) { - /* Called with G_DISCARD, so our return stack state is thrown away. - Hence if we were returned anything, free it immediately. */ - SvREFCNT_dec(ret); - } else { - PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); - } - PUTBACK; - return; + REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + U32 flags; + SV *ret; + const U32 action = ix & ACTION_MASK; + const int expect = ix >> EXPECT_SHIFT; + if (items != expect) + croak_xs_usage(cv, expect == 2 ? "$key" + : (expect == 3 ? "$key, $value" + : "")); + + if (!rx || !SvROK(ST(0))) { + if (ix & UNDEF_FATAL) + Perl_croak_no_modify(); + else + XSRETURN_UNDEF; + } + + flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); + + PUTBACK; + ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL, + expect >= 3 ? ST(2) : NULL, flags | action); + SPAGAIN; + + if (ix & DISCARD) { + /* Called with G_DISCARD, so our return stack state is thrown away. + Hence if we were returned anything, free it immediately. */ + SvREFCNT_dec(ret); + } else { + PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); + } + PUTBACK; + return; } } @@ -1203,28 +1203,28 @@ XS(XS_NamedCapture_FIRSTKEY) PERL_UNUSED_VAR(ax); /* -Wall */ SP -= items; { - REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - U32 flags; - SV *ret; - const int expect = ix ? 2 : 1; - const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY; - if (items != expect) - croak_xs_usage(cv, expect == 2 ? "$lastkey" : ""); - - if (!rx || !SvROK(ST(0))) - XSRETURN_UNDEF; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - - PUTBACK; - ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), - expect >= 2 ? ST(1) : NULL, - flags | action); - SPAGAIN; - - PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); - PUTBACK; - return; + REGEXP *const rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + U32 flags; + SV *ret; + const int expect = ix ? 2 : 1; + const U32 action = ix ? RXapif_NEXTKEY : RXapif_FIRSTKEY; + if (items != expect) + croak_xs_usage(cv, expect == 2 ? "$lastkey" : ""); + + if (!rx || !SvROK(ST(0))) + XSRETURN_UNDEF; + + flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); + + PUTBACK; + ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), + expect >= 2 ? ST(1) : NULL, + flags | action); + SPAGAIN; + + PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); + PUTBACK; + return; } } @@ -1236,11 +1236,11 @@ XS(XS_NamedCapture_flags) PERL_UNUSED_VAR(ax); /* -Wall */ SP -= items; { - EXTEND(SP, 2); - mPUSHu(RXapif_ONE); - mPUSHu(RXapif_ALL); - PUTBACK; - return; + EXTEND(SP, 2); + mPUSHu(RXapif_ONE); + mPUSHu(RXapif_ALL); + PUTBACK; + return; } } @@ -1374,13 +1374,13 @@ Perl_boot_core_UNIVERSAL(pTHX) /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */ { - CV * const cv = - newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL); - char ** cvfile = &CvFILE(cv); - char * oldfile = *cvfile; - CvDYNFILE_off(cv); - *cvfile = (char *)file; - Safefree(oldfile); + CV * const cv = + newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL); + char ** cvfile = &CvFILE(cv); + char * oldfile = *cvfile; + CvDYNFILE_off(cv); + *cvfile = (char *)file; + Safefree(oldfile); } } @@ -137,7 +137,7 @@ int afstat(int fd, struct stat *statb); #if defined(__amigaos4__) # define PERL_SYS_INIT_BODY(c,v) \ - MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT; PERLIO_INIT; MALLOC_INIT; amigaos4_init_fork_array(); amigaos4_init_environ_sema(); + MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT; PERLIO_INIT; MALLOC_INIT; amigaos4_init_fork_array(); amigaos4_init_environ_sema(); # define PERL_SYS_TERM_BODY() \ HINTS_REFCNT_TERM; KEYWORD_PLUGIN_MUTEX_TERM; \ OP_CHECK_MUTEX_TERM; OP_REFCNT_TERM; PERLIO_TERM; \ @@ -148,7 +148,7 @@ int afstat(int fd, struct stat *statb); #ifndef PERL_SYS_INIT_BODY # define PERL_SYS_INIT_BODY(c,v) \ - MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT; PERLIO_INIT; MALLOC_INIT + MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT; PERLIO_INIT; MALLOC_INIT #endif #ifndef PERL_SYS_TERM_BODY @@ -99,7 +99,7 @@ Perl__force_out_malformed_utf8_message(pTHX_ LEAVE; if (! errors) { - Perl_croak(aTHX_ "panic: _force_out_malformed_utf8_message should" + Perl_croak(aTHX_ "panic: _force_out_malformed_utf8_message should" " be called only when there are errors found"); } @@ -264,8 +264,8 @@ Perl_uvoffuni_to_utf8_flags_msgs(pTHX_ U8 *d, UV uv, const UV flags, HV** msgs) } if (OFFUNI_IS_INVARIANT(uv)) { - *d++ = LATIN1_TO_NATIVE(uv); - return d; + *d++ = LATIN1_TO_NATIVE(uv); + return d; } if (uv <= MAX_UTF8_TWO_BYTE) { @@ -281,9 +281,9 @@ Perl_uvoffuni_to_utf8_flags_msgs(pTHX_ U8 *d, UV uv, const UV flags, HV** msgs) * on ASCII; so 3 bytes covers the range 0x400-0x3FFF on EBCDIC; * 0x800-0xFFFF on ASCII */ if (uv < (16 * (1U << (2 * SHIFT)))) { - *d++ = I8_TO_NATIVE_UTF8(( uv >> ((3 - 1) * SHIFT)) | UTF_START_MARK(3)); - *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * SHIFT)) & MASK) | MARK); - *d++ = I8_TO_NATIVE_UTF8(( uv /* (1 - 1) */ & MASK) | MARK); + *d++ = I8_TO_NATIVE_UTF8(( uv >> ((3 - 1) * SHIFT)) | UTF_START_MARK(3)); + *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * SHIFT)) & MASK) | MARK); + *d++ = I8_TO_NATIVE_UTF8(( uv /* (1 - 1) */ & MASK) | MARK); #ifndef EBCDIC /* These problematic code points are 4 bytes on EBCDIC, so aren't tested here */ @@ -300,7 +300,7 @@ Perl_uvoffuni_to_utf8_flags_msgs(pTHX_ U8 *d, UV uv, const UV flags, HV** msgs) } } #endif - return d; + return d; } /* Not 3-byte; that means the code point is at least 0x1_0000 on ASCII @@ -364,10 +364,10 @@ Perl_uvoffuni_to_utf8_flags_msgs(pTHX_ U8 *d, UV uv, const UV flags, HV** msgs) * ASCII, so 4 bytes covers the range 0x4000-0x3_FFFF on EBCDIC; * 0x1_0000-0x1F_FFFF on ASCII */ if (uv < (8 * (1U << (3 * SHIFT)))) { - *d++ = I8_TO_NATIVE_UTF8(( uv >> ((4 - 1) * SHIFT)) | UTF_START_MARK(4)); - *d++ = I8_TO_NATIVE_UTF8(((uv >> ((3 - 1) * SHIFT)) & MASK) | MARK); - *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * SHIFT)) & MASK) | MARK); - *d++ = I8_TO_NATIVE_UTF8(( uv /* (1 - 1) */ & MASK) | MARK); + *d++ = I8_TO_NATIVE_UTF8(( uv >> ((4 - 1) * SHIFT)) | UTF_START_MARK(4)); + *d++ = I8_TO_NATIVE_UTF8(((uv >> ((3 - 1) * SHIFT)) & MASK) | MARK); + *d++ = I8_TO_NATIVE_UTF8(((uv >> ((2 - 1) * SHIFT)) & MASK) | MARK); + *d++ = I8_TO_NATIVE_UTF8(( uv /* (1 - 1) */ & MASK) | MARK); #ifdef EBCDIC /* These were handled on ASCII platforms in the code for 3-byte characters. The end-plane non-characters for EBCDIC were @@ -380,7 +380,7 @@ Perl_uvoffuni_to_utf8_flags_msgs(pTHX_ U8 *d, UV uv, const UV flags, HV** msgs) } #endif - return d; + return d; } /* Not 4-byte; that means the code point is at least 0x20_0000 on ASCII @@ -391,14 +391,14 @@ Perl_uvoffuni_to_utf8_flags_msgs(pTHX_ U8 *d, UV uv, const UV flags, HV** msgs) * khw believes that less code outweighs slight performance gains. */ { - STRLEN len = OFFUNISKIP(uv); - U8 *p = d+len-1; - while (p > d) { - *p-- = I8_TO_NATIVE_UTF8((uv & MASK) | MARK); - uv >>= SHIFT; - } - *p = I8_TO_NATIVE_UTF8((uv & UTF_START_MASK(len)) | UTF_START_MARK(len)); - return d+len; + STRLEN len = OFFUNISKIP(uv); + U8 *p = d+len-1; + while (p > d) { + *p-- = I8_TO_NATIVE_UTF8((uv & MASK) | MARK); + uv >>= SHIFT; + } + *p = I8_TO_NATIVE_UTF8((uv & UTF_START_MASK(len)) | UTF_START_MARK(len)); + return d+len; } } @@ -1659,7 +1659,7 @@ Perl__utf8n_to_uvchr_msgs_helper(const U8 *s, possible_problems |= UTF8_GOT_EMPTY; curlen = 0; uv = UNICODE_REPLACEMENT; - goto ready_to_handle_errors; + goto ready_to_handle_errors; } expectlen = UTF8SKIP(s); @@ -1669,15 +1669,15 @@ Perl__utf8n_to_uvchr_msgs_helper(const U8 *s, * things up here to return it. It will be overriden only in those rare * cases where a malformation is found */ if (retlen) { - *retlen = expectlen; + *retlen = expectlen; } /* A continuation character can't start a valid sequence */ if (UNLIKELY(UTF8_IS_CONTINUATION(uv))) { - possible_problems |= UTF8_GOT_CONTINUATION; + possible_problems |= UTF8_GOT_CONTINUATION; curlen = 1; uv = UNICODE_REPLACEMENT; - goto ready_to_handle_errors; + goto ready_to_handle_errors; } /* Here is not a continuation byte, nor an invariant. The only thing left @@ -1703,8 +1703,8 @@ Perl__utf8n_to_uvchr_msgs_helper(const U8 *s, /* Now, loop through the remaining bytes in the character's sequence, * accumulating each into the working value as we go. */ for (s = s0 + 1; s < send; s++) { - if (LIKELY(UTF8_IS_CONTINUATION(*s))) { - uv = UTF8_ACCUMULATE(uv, *s); + if (LIKELY(UTF8_IS_CONTINUATION(*s))) { + uv = UTF8_ACCUMULATE(uv, *s); continue; } @@ -1808,11 +1808,11 @@ Perl__utf8n_to_uvchr_msgs_helper(const U8 *s, && LIKELY(! (possible_problems & UTF8_GOT_OVERFLOW)) && ( isUTF8_POSSIBLY_PROBLEMATIC(*adjusted_s0) || UNLIKELY(isUTF8_PERL_EXTENDED(s0))))) - && ((flags & ( UTF8_DISALLOW_NONCHAR + && ((flags & ( UTF8_DISALLOW_NONCHAR |UTF8_DISALLOW_SURROGATE |UTF8_DISALLOW_SUPER |UTF8_DISALLOW_PERL_EXTENDED - |UTF8_WARN_NONCHAR + |UTF8_WARN_NONCHAR |UTF8_WARN_SURROGATE |UTF8_WARN_SUPER |UTF8_WARN_PERL_EXTENDED)))) @@ -2373,20 +2373,20 @@ Perl_utf8_length(pTHX_ const U8 *s, const U8 *e) * In other words: in Perl UTF-8 is not just for Unicode. */ if (UNLIKELY(e < s)) - goto warn_and_return; + goto warn_and_return; while (s < e) { s += UTF8SKIP(s); - len++; + len++; } if (UNLIKELY(e != s)) { - len--; + len--; warn_and_return: - if (PL_op) - Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), - "%s in %s", unees, OP_DESC(PL_op)); - else - Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees); + if (PL_op) + Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), + "%s in %s", unees, OP_DESC(PL_op)); + else + Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees); } return len; @@ -2419,41 +2419,41 @@ Perl_bytes_cmp_utf8(pTHX_ const U8 *b, STRLEN blen, const U8 *u, STRLEN ulen) while (b < bend && u < uend) { U8 c = *u++; - if (!UTF8_IS_INVARIANT(c)) { - if (UTF8_IS_DOWNGRADEABLE_START(c)) { - if (u < uend) { - U8 c1 = *u++; - if (UTF8_IS_CONTINUATION(c1)) { - c = EIGHT_BIT_UTF8_TO_NATIVE(c, c1); - } else { + if (!UTF8_IS_INVARIANT(c)) { + if (UTF8_IS_DOWNGRADEABLE_START(c)) { + if (u < uend) { + U8 c1 = *u++; + if (UTF8_IS_CONTINUATION(c1)) { + c = EIGHT_BIT_UTF8_TO_NATIVE(c, c1); + } else { /* diag_listed_as: Malformed UTF-8 character%s */ - Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), + Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s %s%s", unexpected_non_continuation_text(u - 2, 2, 1, 2), PL_op ? " in " : "", PL_op ? OP_DESC(PL_op) : ""); - return -2; - } - } else { - if (PL_op) - Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), - "%s in %s", unees, OP_DESC(PL_op)); - else - Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees); - return -2; /* Really want to return undef :-) */ - } - } else { - return -2; - } - } - if (*b != c) { - return *b < c ? -2 : +2; - } - ++b; + return -2; + } + } else { + if (PL_op) + Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), + "%s in %s", unees, OP_DESC(PL_op)); + else + Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "%s", unees); + return -2; /* Really want to return undef :-) */ + } + } else { + return -2; + } + } + if (*b != c) { + return *b < c ? -2 : +2; + } + ++b; } if (b == bend && u == uend) - return 0; + return 0; return b < bend ? +1 : -1; } @@ -2737,23 +2737,23 @@ Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, Size_t bytelen, Size_t *newlen) PERL_ARGS_ASSERT_UTF16_TO_UTF8; if (bytelen & 1) - Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %" UVuf, + Perl_croak(aTHX_ "panic: utf16_to_utf8: odd bytelen %" UVuf, (UV)bytelen); pend = p + bytelen; while (p < pend) { - UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */ - p += 2; - if (OFFUNI_IS_INVARIANT(uv)) { - *d++ = LATIN1_TO_NATIVE((U8) uv); - continue; - } - if (uv <= MAX_UTF8_TWO_BYTE) { - *d++ = UTF8_TWO_BYTE_HI(UNI_TO_NATIVE(uv)); - *d++ = UTF8_TWO_BYTE_LO(UNI_TO_NATIVE(uv)); - continue; - } + UV uv = (p[0] << 8) + p[1]; /* UTF-16BE */ + p += 2; + if (OFFUNI_IS_INVARIANT(uv)) { + *d++ = LATIN1_TO_NATIVE((U8) uv); + continue; + } + if (uv <= MAX_UTF8_TWO_BYTE) { + *d++ = UTF8_TWO_BYTE_HI(UNI_TO_NATIVE(uv)); + *d++ = UTF8_TWO_BYTE_LO(UNI_TO_NATIVE(uv)); + continue; + } #define FIRST_HIGH_SURROGATE UNICODE_SURROGATE_FIRST #define LAST_HIGH_SURROGATE 0xDBFF @@ -2763,40 +2763,40 @@ Perl_utf16_to_utf8(pTHX_ U8* p, U8* d, Size_t bytelen, Size_t *newlen) /* This assumes that most uses will be in the first Unicode plane, not * needing surrogates */ - if (UNLIKELY(inRANGE(uv, UNICODE_SURROGATE_FIRST, + if (UNLIKELY(inRANGE(uv, UNICODE_SURROGATE_FIRST, UNICODE_SURROGATE_LAST))) { if (UNLIKELY(p >= pend) || UNLIKELY(uv > LAST_HIGH_SURROGATE)) { Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); } - else { - UV low = (p[0] << 8) + p[1]; - if (UNLIKELY(! inRANGE(low, FIRST_LOW_SURROGATE, + else { + UV low = (p[0] << 8) + p[1]; + if (UNLIKELY(! inRANGE(low, FIRST_LOW_SURROGATE, LAST_LOW_SURROGATE))) { - Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); + Perl_croak(aTHX_ "Malformed UTF-16 surrogate"); } - p += 2; - uv = ((uv - FIRST_HIGH_SURROGATE) << 10) + p += 2; + uv = ((uv - FIRST_HIGH_SURROGATE) << 10) + (low - FIRST_LOW_SURROGATE) + FIRST_IN_PLANE1; - } - } + } + } #ifdef EBCDIC d = uvoffuni_to_utf8_flags(d, uv, 0); #else - if (uv < FIRST_IN_PLANE1) { - *d++ = (U8)(( uv >> 12) | 0xe0); - *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); - *d++ = (U8)(( uv & 0x3f) | 0x80); - continue; - } - else { - *d++ = (U8)(( uv >> 18) | 0xf0); - *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); - *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); - *d++ = (U8)(( uv & 0x3f) | 0x80); - continue; - } + if (uv < FIRST_IN_PLANE1) { + *d++ = (U8)(( uv >> 12) | 0xe0); + *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); + *d++ = (U8)(( uv & 0x3f) | 0x80); + continue; + } + else { + *d++ = (U8)(( uv >> 18) | 0xf0); + *d++ = (U8)(((uv >> 12) & 0x3f) | 0x80); + *d++ = (U8)(((uv >> 6) & 0x3f) | 0x80); + *d++ = (U8)(( uv & 0x3f) | 0x80); + continue; + } #endif } *newlen = d - dstart; @@ -2814,14 +2814,14 @@ Perl_utf16_to_utf8_reversed(pTHX_ U8* p, U8* d, Size_t bytelen, Size_t *newlen) PERL_ARGS_ASSERT_UTF16_TO_UTF8_REVERSED; if (bytelen & 1) - Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %" UVuf, - (UV)bytelen); + Perl_croak(aTHX_ "panic: utf16_to_utf8_reversed: odd bytelen %" UVuf, + (UV)bytelen); while (s < send) { - const U8 tmp = s[0]; - s[0] = s[1]; - s[1] = tmp; - s += 2; + const U8 tmp = s[0]; + s[0] = s[1]; + s[1] = tmp; + s += 2; } return utf16_to_utf8(p, d, bytelen, newlen); } @@ -2861,38 +2861,38 @@ Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp, assert(S_or_s == 'S' || S_or_s == 's'); if (UVCHR_IS_INVARIANT(converted)) { /* No difference between the two for - characters in this range */ - *p = (U8) converted; - *lenp = 1; - return converted; + characters in this range */ + *p = (U8) converted; + *lenp = 1; + return converted; } /* toUPPER_LATIN1_MOD gives the correct results except for three outliers, * which it maps to one of them, so as to only have to have one check for * it in the main case */ if (UNLIKELY(converted == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) { - switch (c) { - case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS: - converted = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS; - break; - case MICRO_SIGN: - converted = GREEK_CAPITAL_LETTER_MU; - break; + switch (c) { + case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS: + converted = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS; + break; + case MICRO_SIGN: + converted = GREEK_CAPITAL_LETTER_MU; + break; #if UNICODE_MAJOR_VERSION > 2 \ || (UNICODE_MAJOR_VERSION == 2 && UNICODE_DOT_VERSION >= 1 \ && UNICODE_DOT_DOT_VERSION >= 8) - case LATIN_SMALL_LETTER_SHARP_S: - *(p)++ = 'S'; - *p = S_or_s; - *lenp = 2; - return 'S'; + case LATIN_SMALL_LETTER_SHARP_S: + *(p)++ = 'S'; + *p = S_or_s; + *lenp = 2; + return 'S'; #endif - default: - Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect" + default: + Perl_croak(aTHX_ "panic: to_upper_title_latin1 did not expect" " '%c' to map to '%c'", c, LATIN_SMALL_LETTER_Y_WITH_DIAERESIS); - NOT_REACHED; /* NOTREACHED */ - } + NOT_REACHED; /* NOTREACHED */ + } } *(p)++ = UTF8_TWO_BYTE_HI(converted); @@ -2983,7 +2983,7 @@ Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp) PERL_ARGS_ASSERT_TO_UNI_UPPER; if (c < 256) { - return _to_upper_title_latin1((U8) c, p, lenp, 'S'); + return _to_upper_title_latin1((U8) c, p, lenp, 'S'); } return CALL_UPPER_CASE(c, NULL, p, lenp); @@ -2995,7 +2995,7 @@ Perl_to_uni_title(pTHX_ UV c, U8* p, STRLEN *lenp) PERL_ARGS_ASSERT_TO_UNI_TITLE; if (c < 256) { - return _to_upper_title_latin1((U8) c, p, lenp, 's'); + return _to_upper_title_latin1((U8) c, p, lenp, 's'); } return CALL_TITLE_CASE(c, NULL, p, lenp); @@ -3013,17 +3013,17 @@ S_to_lower_latin1(const U8 c, U8* p, STRLEN *lenp, const char dummy) PERL_UNUSED_ARG(dummy); if (p != NULL) { - if (NATIVE_BYTE_IS_INVARIANT(converted)) { - *p = converted; - *lenp = 1; - } - else { + if (NATIVE_BYTE_IS_INVARIANT(converted)) { + *p = converted; + *lenp = 1; + } + else { /* Result is known to always be < 256, so can use the EIGHT_BIT * macros */ - *p = UTF8_EIGHT_BIT_HI(converted); - *(p+1) = UTF8_EIGHT_BIT_LO(converted); - *lenp = 2; - } + *p = UTF8_EIGHT_BIT_HI(converted); + *(p+1) = UTF8_EIGHT_BIT_LO(converted); + *lenp = 2; + } } return converted; } @@ -3034,7 +3034,7 @@ Perl_to_uni_lower(pTHX_ UV c, U8* p, STRLEN *lenp) PERL_ARGS_ASSERT_TO_UNI_LOWER; if (c < 256) { - return to_lower_latin1((U8) c, p, lenp, 0 /* 0 is a dummy arg */ ); + return to_lower_latin1((U8) c, p, lenp, 0 /* 0 is a dummy arg */ ); } return CALL_LOWER_CASE(c, NULL, p, lenp); @@ -3057,7 +3057,7 @@ Perl__to_fold_latin1(const U8 c, U8* p, STRLEN *lenp, const unsigned int flags) assert (! (flags & FOLD_FLAGS_LOCALE)); if (UNLIKELY(c == MICRO_SIGN)) { - converted = GREEK_SMALL_LETTER_MU; + converted = GREEK_SMALL_LETTER_MU; } #if UNICODE_MAJOR_VERSION > 3 /* no multifolds in early Unicode */ \ || (UNICODE_MAJOR_VERSION == 3 && ( UNICODE_DOT_VERSION > 0) \ @@ -3084,17 +3084,17 @@ Perl__to_fold_latin1(const U8 c, U8* p, STRLEN *lenp, const unsigned int flags) #endif else { /* In this range the fold of all other characters is their lower case */ - converted = toLOWER_LATIN1(c); + converted = toLOWER_LATIN1(c); } if (UVCHR_IS_INVARIANT(converted)) { - *p = (U8) converted; - *lenp = 1; + *p = (U8) converted; + *lenp = 1; } else { - *(p)++ = UTF8_TWO_BYTE_HI(converted); - *p = UTF8_TWO_BYTE_LO(converted); - *lenp = 2; + *(p)++ = UTF8_TWO_BYTE_HI(converted); + *p = UTF8_TWO_BYTE_LO(converted); + *lenp = 2; } return converted; @@ -3128,20 +3128,20 @@ Perl__to_uni_fold_flags(pTHX_ UV c, U8* p, STRLEN *lenp, U8 flags) if (c < 256) { return _to_fold_latin1((U8) c, p, lenp, - flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII)); + flags & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII)); } /* Here, above 255. If no special needs, just use the macro */ if ( ! (flags & (FOLD_FLAGS_LOCALE|FOLD_FLAGS_NOMIX_ASCII))) { - return CALL_FOLD_CASE(c, NULL, p, lenp, flags & FOLD_FLAGS_FULL); + return CALL_FOLD_CASE(c, NULL, p, lenp, flags & FOLD_FLAGS_FULL); } else { /* Otherwise, _toFOLD_utf8_flags has the intelligence to deal with - the special flags. */ - U8 utf8_c[UTF8_MAXBYTES + 1]; + the special flags. */ + U8 utf8_c[UTF8_MAXBYTES + 1]; needs_full_generality: - uvchr_to_utf8(utf8_c, c); - return _toFOLD_utf8_flags(utf8_c, utf8_c + sizeof(utf8_c), + uvchr_to_utf8(utf8_c, c); + return _toFOLD_utf8_flags(utf8_c, utf8_c + sizeof(utf8_c), p, lenp, flags); } } @@ -3184,14 +3184,14 @@ S_warn_on_first_deprecated_use(pTHX_ const char * const name, if (ckWARN_d(WARN_DEPRECATED)) { key = Perl_form(aTHX_ "%s;%d;%s;%d", name, use_locale, file, line); - if (! hv_fetch(PL_seen_deprecated_macro, key, strlen(key), 0)) { + if (! hv_fetch(PL_seen_deprecated_macro, key, strlen(key), 0)) { if (! PL_seen_deprecated_macro) { PL_seen_deprecated_macro = newHV(); } if (! hv_store(PL_seen_deprecated_macro, key, strlen(key), &PL_sv_undef, 0)) { - Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed"); + Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed"); } if (instr(file, "mathoms.c")) { @@ -3344,7 +3344,7 @@ S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, } } - /* Note that non-characters are perfectly legal, so no warning should + /* Note that non-characters are perfectly legal, so no warning should * be given. */ } @@ -3401,7 +3401,7 @@ S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, *lenp = len; } else { - *lenp = uvchr_to_utf8(ustrp, uv1) - ustrp; + *lenp = uvchr_to_utf8(ustrp, uv1) - ustrp; } return uv1; @@ -3503,20 +3503,20 @@ S_check_locale_boundary_crossing(pTHX_ const U8* const p, const UV result, * boundary, so can skip testing */ if (result > 255) { - /* Look at every character in the result; if any cross the - * boundary, the whole thing is disallowed */ - U8* s = ustrp + UTF8SKIP(ustrp); - U8* e = ustrp + *lenp; - while (s < e) { - if (! UTF8_IS_ABOVE_LATIN1(*s)) { - goto bad_crossing; - } - s += UTF8SKIP(s); - } + /* Look at every character in the result; if any cross the + * boundary, the whole thing is disallowed */ + U8* s = ustrp + UTF8SKIP(ustrp); + U8* e = ustrp + *lenp; + while (s < e) { + if (! UTF8_IS_ABOVE_LATIN1(*s)) { + goto bad_crossing; + } + s += UTF8SKIP(s); + } /* Here, no characters crossed, result is ok as-is, but we warn. */ _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(p, p + UTF8SKIP(p)); - return result; + return result; } bad_crossing: @@ -3838,9 +3838,9 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, ((flags) & (FOLD_FLAGS_FULL | FOLD_FLAGS_NOMIX_ASCII)), turkic_fc); - result = CALL_FOLD_CASE(result, p, ustrp, lenp, flags & FOLD_FLAGS_FULL); + result = CALL_FOLD_CASE(result, p, ustrp, lenp, flags & FOLD_FLAGS_FULL); - if (flags & FOLD_FLAGS_LOCALE) { + if (flags & FOLD_FLAGS_LOCALE) { # define LONG_S_T LATIN_SMALL_LIGATURE_LONG_S_T_UTF8 # ifdef LATIN_CAPITAL_LETTER_SHARP_S_UTF8 @@ -3886,26 +3886,26 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, } #endif - return check_locale_boundary_crossing(p, result, ustrp, lenp); - } - else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) { - return result; - } - else { - /* This is called when changing the case of a UTF-8-encoded + return check_locale_boundary_crossing(p, result, ustrp, lenp); + } + else if (! (flags & FOLD_FLAGS_NOMIX_ASCII)) { + return result; + } + else { + /* This is called when changing the case of a UTF-8-encoded * character above the ASCII range, and the result should not * contain an ASCII character. */ - UV original; /* To store the first code point of <p> */ + UV original; /* To store the first code point of <p> */ - /* Look at every character in the result; if any cross the - * boundary, the whole thing is disallowed */ - U8* s = ustrp; - U8* send = ustrp + *lenp; - while (s < send) { - if (isASCII(*s)) { - /* Crossed, have to return the original */ - original = valid_utf8_to_uvchr(p, lenp); + /* Look at every character in the result; if any cross the + * boundary, the whole thing is disallowed */ + U8* s = ustrp; + U8* send = ustrp + *lenp; + while (s < send) { + if (isASCII(*s)) { + /* Crossed, have to return the original */ + original = valid_utf8_to_uvchr(p, lenp); /* But in these instances, there is an alternative we can * return that is valid */ @@ -3927,26 +3927,26 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, goto return_dotless_i; } #endif - Copy(p, ustrp, *lenp, char); - return original; - } - s += UTF8SKIP(s); - } - - /* Here, no characters crossed, result is ok as-is */ - return result; - } + Copy(p, ustrp, *lenp, char); + return original; + } + s += UTF8SKIP(s); + } + + /* Here, no characters crossed, result is ok as-is */ + return result; + } } /* Here, used locale rules. Convert back to UTF-8 */ if (UTF8_IS_INVARIANT(result)) { - *ustrp = (U8) result; - *lenp = 1; + *ustrp = (U8) result; + *lenp = 1; } else { - *ustrp = UTF8_EIGHT_BIT_HI((U8) result); - *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result); - *lenp = 2; + *ustrp = UTF8_EIGHT_BIT_HI((U8) result); + *(ustrp + 1) = UTF8_EIGHT_BIT_LO((U8) result); + *lenp = 2; } return result; @@ -3999,13 +3999,13 @@ Perl_check_utf8_print(pTHX_ const U8* s, const STRLEN len) PERL_ARGS_ASSERT_CHECK_UTF8_PRINT; while (s < e) { - if (UTF8SKIP(s) > len) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), - "%s in %s", unees, PL_op ? OP_DESC(PL_op) : "print"); - return FALSE; - } - if (UNLIKELY(isUTF8_POSSIBLY_PROBLEMATIC(*s))) { - if (UNLIKELY(UTF8_IS_SUPER(s, e))) { + if (UTF8SKIP(s) > len) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), + "%s in %s", unees, PL_op ? OP_DESC(PL_op) : "print"); + return FALSE; + } + if (UNLIKELY(isUTF8_POSSIBLY_PROBLEMATIC(*s))) { + if (UNLIKELY(UTF8_IS_SUPER(s, e))) { if ( ckWARN_d(WARN_NON_UNICODE) || UNLIKELY(0 < does_utf8_overflow(s, s + len, 0 /* Don't consider overlongs */ @@ -4015,28 +4015,28 @@ Perl_check_utf8_print(pTHX_ const U8* s, const STRLEN len) (void) utf8n_to_uvchr(s, e - s, NULL, UTF8_WARN_SUPER); ok = FALSE; } - } - else if (UNLIKELY(UTF8_IS_SURROGATE(s, e))) { - if (ckWARN_d(WARN_SURROGATE)) { + } + else if (UNLIKELY(UTF8_IS_SURROGATE(s, e))) { + if (ckWARN_d(WARN_SURROGATE)) { /* This has a different warning than the one the called * function would output, so can't just call it, unlike we * do for the non-chars and above-unicodes */ - UV uv = utf8_to_uvchr_buf(s, e, NULL); - Perl_warner(aTHX_ packWARN(WARN_SURROGATE), - "Unicode surrogate U+%04" UVXf " is illegal in UTF-8", + UV uv = utf8_to_uvchr_buf(s, e, NULL); + Perl_warner(aTHX_ packWARN(WARN_SURROGATE), + "Unicode surrogate U+%04" UVXf " is illegal in UTF-8", uv); - ok = FALSE; - } - } - else if ( UNLIKELY(UTF8_IS_NONCHAR(s, e)) + ok = FALSE; + } + } + else if ( UNLIKELY(UTF8_IS_NONCHAR(s, e)) && (ckWARN_d(WARN_NONCHAR))) { /* A side effect of this function will be to warn */ (void) utf8n_to_uvchr(s, e - s, NULL, UTF8_WARN_NONCHAR); - ok = FALSE; - } - } - s += UTF8SKIP(s); + ok = FALSE; + } + } + s += UTF8SKIP(s); } return ok; @@ -4082,17 +4082,17 @@ Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, SvPVCLEAR(dsv); SvUTF8_off(dsv); for (s = (const char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) { - UV u; - bool ok = 0; - - if (pvlim && SvCUR(dsv) >= pvlim) { - truncated++; - break; - } - u = utf8_to_uvchr_buf((U8*)s, (U8*)e, 0); - if (u < 256) { - const unsigned char c = (unsigned char)u & 0xFF; - if (flags & UNI_DISPLAY_BACKSLASH) { + UV u; + bool ok = 0; + + if (pvlim && SvCUR(dsv) >= pvlim) { + truncated++; + break; + } + u = utf8_to_uvchr_buf((U8*)s, (U8*)e, 0); + if (u < 256) { + const unsigned char c = (unsigned char)u & 0xFF; + if (flags & UNI_DISPLAY_BACKSLASH) { if ( isMNEMONIC_CNTRL(c) && ( c != '\b' || (flags & UNI_DISPLAY_BACKSPACE))) @@ -4106,18 +4106,18 @@ Perl_pv_uni_display(pTHX_ SV *dsv, const U8 *spv, STRLEN len, STRLEN pvlim, ok = 1; } } - /* isPRINT() is the locale-blind version. */ - if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) { - const char string = c; - sv_catpvn(dsv, &string, 1); - ok = 1; - } - } - if (!ok) - Perl_sv_catpvf(aTHX_ dsv, "\\x{%" UVxf "}", u); + /* isPRINT() is the locale-blind version. */ + if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(c)) { + const char string = c; + sv_catpvn(dsv, &string, 1); + ok = 1; + } + } + if (!ok) + Perl_sv_catpvf(aTHX_ dsv, "\\x{%" UVxf "}", u); } if (truncated) - sv_catpvs(dsv, "..."); + sv_catpvs(dsv, "..."); return SvPVX(dsv); } @@ -4144,7 +4144,7 @@ Perl_sv_uni_display(pTHX_ SV *dsv, SV *ssv, STRLEN pvlim, UV flags) PERL_ARGS_ASSERT_SV_UNI_DISPLAY; return Perl_pv_uni_display(aTHX_ dsv, (const U8*)ptr, - SvCUR(ssv), pvlim, flags); + SvCUR(ssv), pvlim, flags); } /* @@ -4202,7 +4202,7 @@ L<https://www.unicode.org/unicode/reports/tr21/> (Case Mappings). * externally documented. Currently it is: * 0 for as-documented above * FOLDEQ_UTF8_NOMIX_ASCII meaning that if a non-ASCII character folds to an - ASCII one, to not match + ASCII one, to not match * FOLDEQ_LOCALE is set iff the rules from the current underlying * locale are to be used. * FOLDEQ_S1_ALREADY_FOLDED s1 has already been folded before calling this @@ -4308,7 +4308,7 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, e1 = g1; } else { - assert(e1); /* Must have an end for looking at s1 */ + assert(e1); /* Must have an end for looking at s1 */ } /* Same for goal for s2 */ @@ -4317,7 +4317,7 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, e2 = g2; } else { - assert(e2); + assert(e2); } /* If both operands are already folded, we could just do a memEQ on the @@ -4328,14 +4328,14 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, while (p1 < e1 && p2 < e2) { /* If at the beginning of a new character in s1, get its fold to use - * and the length of the fold. */ + * and the length of the fold. */ if (n1 == 0) { - if (flags & FOLDEQ_S1_ALREADY_FOLDED) { - f1 = (U8 *) p1; + if (flags & FOLDEQ_S1_ALREADY_FOLDED) { + f1 = (U8 *) p1; assert(u1); - n1 = UTF8SKIP(f1); - } - else { + n1 = UTF8SKIP(f1); + } + else { if (isASCII(*p1) && ! (flags & FOLDEQ_LOCALE)) { /* We have to forbid mixing ASCII with non-ASCII if the @@ -4361,11 +4361,11 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, } if (n2 == 0) { /* Same for s2 */ - if (flags & FOLDEQ_S2_ALREADY_FOLDED) { + if (flags & FOLDEQ_S2_ALREADY_FOLDED) { /* Point to the already-folded character. But for non-UTF-8 * variants, convert to UTF-8 for the algorithm below */ - if (UTF8_IS_INVARIANT(*p2)) { + if (UTF8_IS_INVARIANT(*p2)) { f2 = (U8 *) p2; n2 = 1; } @@ -4379,8 +4379,8 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, f2 = foldbuf2; n2 = 2; } - } - else { + } + else { if (isASCII(*p2) && ! (flags & FOLDEQ_LOCALE)) { if ((flags & FOLDEQ_UTF8_NOMIX_ASCII) && ! isASCII(*p1)) { return 0; @@ -4395,12 +4395,12 @@ Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, _to_uni_fold_flags(*p2, foldbuf2, &n2, flags_for_folder); } f2 = foldbuf2; - } + } } - /* Here f1 and f2 point to the beginning of the strings to compare. - * These strings are the folds of the next character from each input - * string, stored in UTF-8. */ + /* Here f1 and f2 point to the beginning of the strings to compare. + * These strings are the folds of the next character from each input + * string, stored in UTF-8. */ /* While there is more to look for in both folds, see if they * continue to match */ @@ -70,7 +70,7 @@ the string is invariant. #define to_uni_fold(c, p, lenp) _to_uni_fold_flags(c, p, lenp, FOLD_FLAGS_FULL) #define foldEQ_utf8(s1, pe1, l1, u1, s2, pe2, l2, u2) \ - foldEQ_utf8_flags(s1, pe1, l1, u1, s2, pe2, l2, u2, 0) + foldEQ_utf8_flags(s1, pe1, l1, u1, s2, pe2, l2, u2, 0) #define FOLDEQ_UTF8_NOMIX_ASCII (1 << 0) #define FOLDEQ_LOCALE (1 << 1) #define FOLDEQ_S1_ALREADY_FOLDED (1 << 2) @@ -720,7 +720,7 @@ case any call to string overloading updates the internal UTF-8 encoding flag. * within 'use bytes'. UTF-8 locales are not tested for here, but perhaps * could be */ #define IN_UNI_8_BIT \ - (( ( (CopHINTS_get(PL_curcop) & HINT_UNI_8_BIT)) \ + (( ( (CopHINTS_get(PL_curcop) & HINT_UNI_8_BIT)) \ || ( CopHINTS_get(PL_curcop) & HINT_LOCALE_PARTIAL \ /* -1 below is for :not_characters */ \ && _is_in_locale_category(FALSE, -1))) \ diff --git a/utfebcdic.h b/utfebcdic.h index 97b8f7001a..ce9981b427 100644 --- a/utfebcdic.h +++ b/utfebcdic.h @@ -242,7 +242,7 @@ explicitly forbidden, and the shortest possible encoding should always be used #if '^' == 95 /* CP 1047 */ /* UTF8_CHAR: Matches legal UTF-EBCDIC variant code points up through 0x1FFFFFF - 0xA0 - 0x1FFFFF + 0xA0 - 0x1FFFFF */ /*** GENERATED CODE ***/ @@ -264,11 +264,11 @@ explicitly forbidden, and the shortest possible encoding should always be used /*** GENERATED CODE ***/ #define is_STRICT_UTF8_CHAR_utf8_no_length_checks_part0(s) \ ( ( ( 0x41 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x72 ) ) ?\ - ( LIKELY( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ) ? 4 : 0 )\ + ( LIKELY( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ) ? 4 : 0 )\ : ( 0x73 == ((const U8*)s)[1] ) ? \ - ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) ?\ - ( LIKELY( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ? 4 : 0 )\ - : LIKELY( ( 0x73 == ((const U8*)s)[2] ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFE ) == 0x70 ) ) ? 4 : 0 )\ + ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) ?\ + ( LIKELY( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ? 4 : 0 )\ + : LIKELY( ( 0x73 == ((const U8*)s)[2] ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFE ) == 0x70 ) ) ? 4 : 0 )\ : 0 ) @@ -276,27 +276,27 @@ explicitly forbidden, and the shortest possible encoding should always be used #define is_STRICT_UTF8_CHAR_utf8_no_length_checks_part1(s) \ ( ( 0xED == ((const U8*)s)[0] ) ? \ ( ( ( ( ((const U8*)s)[1] & 0xEF ) == 0x49 ) || ( ( ((const U8*)s)[1] & 0xF9 ) == 0x51 ) || ((const U8*)s)[1] == 0x63 || ( ( ((const U8*)s)[1] & 0xFD ) == 0x65 ) || ((const U8*)s)[1] == 0x69 || ( ( ((const U8*)s)[1] & 0xFD ) == 0x70 ) ) ?\ - ( LIKELY( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ) ? 5 : 0 )\ + ( LIKELY( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ) ? 5 : 0 )\ : ( ((const U8*)s)[1] == 0x4A || ((const U8*)s)[1] == 0x52 || ( ( ((const U8*)s)[1] & 0xFD ) == 0x54 ) || ((const U8*)s)[1] == 0x58 || ((const U8*)s)[1] == 0x62 || ( ( ((const U8*)s)[1] & 0xFD ) == 0x64 ) || ( ( ((const U8*)s)[1] & 0xFD ) == 0x68 ) || ( ( ((const U8*)s)[1] & 0xFD ) == 0x71 ) ) ?\ - ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) ?\ - ( LIKELY( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ) ? 5 : 0 )\ - : ( 0x73 == ((const U8*)s)[2] ) ? \ - ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ?\ - ( LIKELY( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ? 5 : 0 )\ - : LIKELY( ( 0x73 == ((const U8*)s)[3] ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFE ) == 0x70 ) ) ? 5 : 0 )\ - : 0 ) \ + ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) ?\ + ( LIKELY( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ) ? 5 : 0 )\ + : ( 0x73 == ((const U8*)s)[2] ) ? \ + ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ?\ + ( LIKELY( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ? 5 : 0 )\ + : LIKELY( ( 0x73 == ((const U8*)s)[3] ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFE ) == 0x70 ) ) ? 5 : 0 )\ + : 0 ) \ : 0 ) \ : ( 0xEE == ((const U8*)s)[0] ) ? \ ( ( 0x41 == ((const U8*)s)[1] ) ? \ - ( LIKELY( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ) ? 5 : 0 )\ + ( LIKELY( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ) ? 5 : 0 )\ : ( 0x42 == ((const U8*)s)[1] ) ? \ - ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) ?\ - ( LIKELY( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ) ? 5 : 0 )\ - : ( 0x73 == ((const U8*)s)[2] ) ? \ - ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ?\ - ( LIKELY( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ? 5 : 0 )\ - : LIKELY( ( 0x73 == ((const U8*)s)[3] ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFE ) == 0x70 ) ) ? 5 : 0 )\ - : 0 ) \ + ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) ?\ + ( LIKELY( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ) ? 5 : 0 )\ + : ( 0x73 == ((const U8*)s)[2] ) ? \ + ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ?\ + ( LIKELY( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFC ) == 0x70 ) ? 5 : 0 )\ + : LIKELY( ( 0x73 == ((const U8*)s)[3] ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( ((const U8*)s)[4] & 0xFE ) == 0x70 ) ) ? 5 : 0 )\ + : 0 ) \ : 0 ) \ : 0 ) @@ -311,15 +311,15 @@ explicitly forbidden, and the shortest possible encoding should always be used ( LIKELY( ( ( ( 0x57 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x6A ) || ( ((const U8*)s)[1] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFC ) == 0x70 ) ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ) ? 4 : 0 )\ : ( 0xDD == ((const U8*)s)[0] ) ? \ ( ( ( 0x41 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x64 ) || ( 0x67 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x72 ) ) ?\ - ( LIKELY( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ) ? 4 : 0 )\ + ( LIKELY( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ) ? 4 : 0 )\ : ( 0x73 == ((const U8*)s)[1] ) ? \ - ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x54 ) || ( 0x57 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) ?\ - ( LIKELY( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ? 4 : 0 )\ - : ( 0x55 == ((const U8*)s)[2] ) ? \ - ( LIKELY( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x56 ) ) ? 4 : 0 )\ - : ( 0x56 == ((const U8*)s)[2] ) ? \ - ( LIKELY( ( 0x57 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ? 4 : 0 )\ - : LIKELY( ( 0x73 == ((const U8*)s)[2] ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFE ) == 0x70 ) ) ? 4 : 0 )\ + ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x54 ) || ( 0x57 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) ?\ + ( LIKELY( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ? 4 : 0 )\ + : ( 0x55 == ((const U8*)s)[2] ) ? \ + ( LIKELY( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x56 ) ) ? 4 : 0 )\ + : ( 0x56 == ((const U8*)s)[2] ) ? \ + ( LIKELY( ( 0x57 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ? 4 : 0 )\ + : LIKELY( ( 0x73 == ((const U8*)s)[2] ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFE ) == 0x70 ) ) ? 4 : 0 )\ : 0 ) \ : ( 0xDE == ((const U8*)s)[0] || 0xE1 == ((const U8*)s)[0] || 0xEB == ((const U8*)s)[0] ) ? \ ( LIKELY( ( ( ( 0x41 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x6A ) || ( ((const U8*)s)[1] & 0xFC ) == 0x70 ) && ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFC ) == 0x70 ) ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFC ) == 0x70 ) ) ? 4 : 0 )\ @@ -327,8 +327,8 @@ explicitly forbidden, and the shortest possible encoding should always be used /* C9_STRICT_UTF8_CHAR: Matches legal Unicode UTF-8 variant code points including non-character code points, no surrogates - 0x00A0 - 0xD7FF - 0xE000 - 0x10FFFF + 0x00A0 - 0xD7FF + 0xE000 - 0x10FFFF */ /*** GENERATED CODE ***/ #define is_C9_STRICT_UTF8_CHAR_utf8_no_length_checks(s) \ @@ -368,15 +368,15 @@ explicitly forbidden, and the shortest possible encoding should always be used /*** GENERATED CODE ***/ #define is_STRICT_UTF8_CHAR_utf8_no_length_checks_part0(s) \ ( ( ( ( ((const U8*)s)[1] & 0xEF ) == 0x49 ) || ( ( ((const U8*)s)[1] & 0xF9 ) == 0x51 ) || ((const U8*)s)[1] == 0x62 || ( ( ((const U8*)s)[1] & 0xFD ) == 0x64 ) || ( ( ((const U8*)s)[1] & 0xFD ) == 0x68 ) || ((const U8*)s)[1] == 0x71 ) ?\ - ( ( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ) ? 5 : 0 )\ + ( ( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ) ? 5 : 0 )\ : ( ((const U8*)s)[1] == 0x4A || ((const U8*)s)[1] == 0x52 || ( ( ((const U8*)s)[1] & 0xFD ) == 0x54 ) || ((const U8*)s)[1] == 0x58 || ((const U8*)s)[1] == 0x5F || ((const U8*)s)[1] == 0x63 || ( ( ((const U8*)s)[1] & 0xFD ) == 0x65 ) || ((const U8*)s)[1] == 0x69 || ( ( ((const U8*)s)[1] & 0xFD ) == 0x70 ) ) ?\ - ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFE ) == 0x70 ) ?\ - ( ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ) ? 5 : 0 )\ - : ( 0x72 == ((const U8*)s)[2] ) ? \ - ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFE ) == 0x70 ) ?\ - ( ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ? 5 : 0 )\ - : ( ( 0x72 == ((const U8*)s)[3] ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || 0x70 == ((const U8*)s)[4] ) ) ? 5 : 0 )\ - : 0 ) \ + ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFE ) == 0x70 ) ?\ + ( ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ) ? 5 : 0 )\ + : ( 0x72 == ((const U8*)s)[2] ) ? \ + ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFE ) == 0x70 ) ?\ + ( ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ? 5 : 0 )\ + : ( ( 0x72 == ((const U8*)s)[3] ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || 0x70 == ((const U8*)s)[4] ) ) ? 5 : 0 )\ + : 0 ) \ : 0 ) @@ -384,15 +384,15 @@ explicitly forbidden, and the shortest possible encoding should always be used #define is_STRICT_UTF8_CHAR_utf8_no_length_checks_part1(s) \ ( ( 0xEE == ((const U8*)s)[0] ) ? \ ( ( 0x41 == ((const U8*)s)[1] ) ? \ - ( ( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ) ? 5 : 0 )\ + ( ( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ) ? 5 : 0 )\ : ( 0x42 == ((const U8*)s)[1] ) ? \ - ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFE ) == 0x70 ) ?\ - ( ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ) ? 5 : 0 )\ - : ( 0x72 == ((const U8*)s)[2] ) ? \ - ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFE ) == 0x70 ) ?\ - ( ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ? 5 : 0 )\ - : ( ( 0x72 == ((const U8*)s)[3] ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || 0x70 == ((const U8*)s)[4] ) ) ? 5 : 0 )\ - : 0 ) \ + ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFE ) == 0x70 ) ?\ + ( ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ) ? 5 : 0 )\ + : ( 0x72 == ((const U8*)s)[2] ) ? \ + ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( ((const U8*)s)[3] & 0xFE ) == 0x70 ) ?\ + ( ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x72 ) ) ? 5 : 0 )\ + : ( ( 0x72 == ((const U8*)s)[3] ) && ( ( 0x41 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x59 ) || 0x5F == ((const U8*)s)[4] || ( 0x62 <= ((const U8*)s)[4] && ((const U8*)s)[4] <= 0x6A ) || 0x70 == ((const U8*)s)[4] ) ) ? 5 : 0 )\ + : 0 ) \ : 0 ) \ : 0 ) @@ -406,25 +406,25 @@ explicitly forbidden, and the shortest possible encoding should always be used #define is_STRICT_UTF8_CHAR_utf8_no_length_checks_part3(s) \ ( ( 0xDD == ((const U8*)s)[0] ) ? \ ( ( ( 0x41 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x59 ) || 0x5F == ((const U8*)s)[1] || ( ((const U8*)s)[1] & 0xFE ) == 0x62 || ( 0x66 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x6A ) || ( ((const U8*)s)[1] & 0xFE ) == 0x70 ) ?\ - ( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ) ? 4 : 0 )\ + ( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ) ? 4 : 0 )\ : ( 0x72 == ((const U8*)s)[1] ) ? \ - ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x54 ) || ( 0x57 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFE ) == 0x70 ) ?\ - ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ? 4 : 0 )\ - : ( 0x55 == ((const U8*)s)[2] ) ? \ - ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x56 ) ) ? 4 : 0 )\ - : ( 0x56 == ((const U8*)s)[2] ) ? \ - ( ( ( 0x57 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ? 4 : 0 )\ - : ( ( 0x72 == ((const U8*)s)[2] ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || 0x70 == ((const U8*)s)[3] ) ) ? 4 : 0 )\ + ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x54 ) || ( 0x57 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFE ) == 0x70 ) ?\ + ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ? 4 : 0 )\ + : ( 0x55 == ((const U8*)s)[2] ) ? \ + ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x56 ) ) ? 4 : 0 )\ + : ( 0x56 == ((const U8*)s)[2] ) ? \ + ( ( ( 0x57 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ? 4 : 0 )\ + : ( ( 0x72 == ((const U8*)s)[2] ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || 0x70 == ((const U8*)s)[3] ) ) ? 4 : 0 )\ : 0 ) \ : ( 0xDE == ((const U8*)s)[0] || 0xE1 == ((const U8*)s)[0] || 0xEB == ((const U8*)s)[0] ) ?\ ( ( ( ( ( 0x41 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x59 ) || 0x5F == ((const U8*)s)[1] || ( 0x62 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ) ? 4 : 0 )\ : ( 0xDF == ((const U8*)s)[0] || 0xEA == ((const U8*)s)[0] || 0xEC == ((const U8*)s)[0] ) ?\ ( ( ( 0x41 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x59 ) || 0x5F == ((const U8*)s)[1] || ( 0x62 <= ((const U8*)s)[1] && ((const U8*)s)[1] <= 0x6A ) || ( ((const U8*)s)[1] & 0xFE ) == 0x70 ) ?\ - ( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ) ? 4 : 0 )\ + ( ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x72 ) ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ) ? 4 : 0 )\ : ( 0x72 == ((const U8*)s)[1] ) ? \ - ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFE ) == 0x70 ) ?\ - ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ? 4 : 0 )\ - : ( ( 0x72 == ((const U8*)s)[2] ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || 0x70 == ((const U8*)s)[3] ) ) ? 4 : 0 )\ + ( ( ( 0x41 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x59 ) || 0x5F == ((const U8*)s)[2] || ( 0x62 <= ((const U8*)s)[2] && ((const U8*)s)[2] <= 0x6A ) || ( ((const U8*)s)[2] & 0xFE ) == 0x70 ) ?\ + ( ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || ( 0x70 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x72 ) ) ? 4 : 0 )\ + : ( ( 0x72 == ((const U8*)s)[2] ) && ( ( 0x41 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x4A ) || ( 0x51 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x59 ) || 0x5F == ((const U8*)s)[3] || ( 0x62 <= ((const U8*)s)[3] && ((const U8*)s)[3] <= 0x6A ) || 0x70 == ((const U8*)s)[3] ) ) ? 4 : 0 )\ : 0 ) \ : ( 0xED == ((const U8*)s)[0] ) ? is_STRICT_UTF8_CHAR_utf8_no_length_checks_part0(s) : is_STRICT_UTF8_CHAR_utf8_no_length_checks_part1(s) ) @@ -439,8 +439,8 @@ explicitly forbidden, and the shortest possible encoding should always be used /* C9_STRICT_UTF8_CHAR: Matches legal Unicode UTF-8 variant code points including non-character code points, no surrogates - 0x00A0 - 0xD7FF - 0xE000 - 0x10FFFF + 0x00A0 - 0xD7FF + 0xE000 - 0x10FFFF */ /*** GENERATED CODE ***/ #define is_C9_STRICT_UTF8_CHAR_utf8_no_length_checks_part0(s) \ @@ -95,8 +95,8 @@ 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); + Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d", + header, header->size, errno); } static void @@ -104,8 +104,8 @@ 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); + 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) @@ -147,15 +147,15 @@ Perl_safesysmalloc(MEM_SIZE size) #endif #ifdef DEBUGGING if ((SSize_t)size < 0) - Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size); + Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size); #endif if (!size) size = 1; /* malloc(0) is NASTY on our system */ SAVE_ERRNO; #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(); + MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { + perror("mmap failed"); + abort(); } #else ptr = (Malloc_t)PerlMem_malloc(size); @@ -163,37 +163,37 @@ Perl_safesysmalloc(MEM_SIZE size) PERL_ALLOC_CHECK(ptr); if (ptr != NULL) { #ifdef USE_MDH - struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)ptr; + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; #endif #ifdef PERL_POISON - PoisonNew(((char *)ptr), size, char); + PoisonNew(((char *)ptr), size, char); #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; - maybe_protect_ro(header->next); + 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; + maybe_protect_ro(header->next); # ifdef PERL_DEBUG_READONLY_COW - header->readonly = 0; + header->readonly = 0; # endif #endif #ifdef MDH_HAS_SIZE - header->size = size; + header->size = size; #endif - ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); + ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); /* malloc() can modify errno() even on success, but since someone - writing perl code doesn't have any control over when perl calls - malloc() we need to hide that. - */ + writing perl code doesn't have any control over when perl calls + malloc() we need to hide that. + */ RESTORE_ERRNO; } else { @@ -229,107 +229,107 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Malloc_t ptr; #ifdef PERL_DEBUG_READONLY_COW const MEM_SIZE oldsize = where - ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size - : 0; + ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size + : 0; #endif if (!size) { - safesysfree(where); - ptr = NULL; + safesysfree(where); + ptr = NULL; } else if (!where) { - ptr = safesysmalloc(size); + ptr = safesysmalloc(size); } else { dSAVE_ERRNO; #ifdef USE_MDH - where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); + where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) goto out_of_memory; - size += PERL_MEMORY_DEBUG_HEADER_SIZE; - { - struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)where; + size += PERL_MEMORY_DEBUG_HEADER_SIZE; + { + 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); - } - assert(header->next->prev == header); - assert(header->prev->next == header); + if (header->interpreter != aTHX) { + Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p", + header->interpreter, aTHX); + } + assert(header->next->prev == header); + assert(header->prev->next == header); # ifdef PERL_POISON - if (header->size > size) { - const MEM_SIZE freed_up = header->size - size; - char *start_of_freed = ((char *)where) + size; - PoisonFree(start_of_freed, freed_up, char); - } + if (header->size > size) { + const MEM_SIZE freed_up = header->size - size; + char *start_of_freed = ((char *)where) + size; + PoisonFree(start_of_freed, freed_up, char); + } # endif # endif # ifdef MDH_HAS_SIZE - header->size = size; + header->size = size; # endif - } + } #endif #ifdef DEBUGGING - if ((SSize_t)size < 0) - Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size); + 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(); - } + 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); + ptr = (Malloc_t)PerlMem_realloc(where,size); #endif - PERL_ALLOC_CHECK(ptr); + 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. */ - if (ptr != NULL) { + if (ptr != NULL) { #ifdef PERL_TRACK_MEMPOOL - struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)ptr; + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; # ifdef PERL_POISON - if (header->size < size) { - const MEM_SIZE fresh = size - header->size; - char *start_of_fresh = ((char *)ptr) + size; - PoisonNew(start_of_fresh, fresh, char); - } + if (header->size < size) { + const MEM_SIZE fresh = size - header->size; + char *start_of_fresh = ((char *)ptr) + size; + PoisonNew(start_of_fresh, fresh, char); + } # 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); + 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+PERL_MEMORY_DEBUG_HEADER_SIZE); + ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); - /* realloc() can modify errno() even on success, but since someone - writing perl code doesn't have any control over when perl calls - realloc() we need to hide that. - */ - RESTORE_ERRNO; - } + /* realloc() can modify errno() even on success, but since someone + writing perl code doesn't have any control over when perl calls + realloc() we need to hide that. + */ + RESTORE_ERRNO; + } /* In particular, must do that fixup above before logging anything via *printf(), as it can reallocate memory, which can cause SEGVs. */ - 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)); + 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 (ptr == NULL) { + if (ptr == NULL) { #ifdef USE_MDH out_of_memory: #endif @@ -342,7 +342,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) else croak_no_mem(); } - } + } } return ptr; } @@ -363,56 +363,56 @@ Perl_safesysfree(Malloc_t where) DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { #ifdef USE_MDH - Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); - { - struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)where_intrn; + Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); + { + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)where_intrn; # ifdef MDH_HAS_SIZE - const MEM_SIZE size = header->size; + 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); - } - if (!header->prev) { - Perl_croak_nocontext("panic: duplicate free"); - } - if (!(header->next)) - Perl_croak_nocontext("panic: bad free, header->next==NULL"); - if (header->next->prev != header || header->prev->next != header) { - Perl_croak_nocontext("panic: bad free, ->next->prev=%p, " - "header=%p, ->prev->next=%p", - header->next->prev, header, - 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); + if (header->interpreter != aTHX) { + Perl_croak_nocontext("panic: free from wrong pool, %p!=%p", + header->interpreter, aTHX); + } + if (!header->prev) { + Perl_croak_nocontext("panic: duplicate free"); + } + if (!(header->next)) + Perl_croak_nocontext("panic: bad free, header->next==NULL"); + if (header->next->prev != header || header->prev->next != header) { + Perl_croak_nocontext("panic: bad free, ->next->prev=%p, " + "header=%p, ->prev->next=%p", + header->next->prev, header, + 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_intrn, size, char); + PoisonNew(where_intrn, size, char); # endif - /* Trigger the duplicate free warning. */ - header->next = NULL; + /* Trigger the duplicate free warning. */ + header->next = NULL; # endif # ifdef PERL_DEBUG_READONLY_COW - if (munmap(where_intrn, size)) { - perror("munmap failed"); - abort(); - } + if (munmap(where_intrn, size)) { + perror("munmap failed"); + abort(); + } # endif - } + } #else - Malloc_t where_intrn = where; + Malloc_t where_intrn = where; #endif /* USE_MDH */ #ifndef PERL_DEBUG_READONLY_COW - PerlMem_free(where_intrn); + PerlMem_free(where_intrn); #endif } } @@ -438,27 +438,27 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) /* Even though calloc() for zero bytes is strange, be robust. */ if (size && (count <= MEM_SIZE_MAX / size)) { #if defined(USE_MDH) || defined(DEBUGGING) - total_size = size * count; + total_size = size * count; #endif } else - croak_memory_wrap(); + croak_memory_wrap(); #ifdef USE_MDH if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size) - total_size += PERL_MEMORY_DEBUG_HEADER_SIZE; + total_size += PERL_MEMORY_DEBUG_HEADER_SIZE; else - croak_memory_wrap(); + croak_memory_wrap(); #endif #ifdef DEBUGGING if ((SSize_t)size < 0 || (SSize_t)count < 0) - Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf, - (UV)size, (UV)count); + Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf, + (UV)size, (UV)count); #endif #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(); + 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 @@ -469,49 +469,49 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) /* Use calloc() because it might save a memset() if the memory is fresh and clean from the OS. */ if (count && size) - ptr = (Malloc_t)PerlMem_calloc(count, size); + ptr = (Malloc_t)PerlMem_calloc(count, size); else /* calloc(0) is non-portable. */ - ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1); + ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1); #endif PERL_ALLOC_CHECK(ptr); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %zu x %zu = %zu bytes\n",PTR2UV(ptr),(long)PL_an++, count, size, total_size)); if (ptr != NULL) { #ifdef USE_MDH - { - struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)ptr; + { + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; # ifndef PERL_DEBUG_READONLY_COW - memset((void*)ptr, 0, total_size); + 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; - maybe_protect_ro(header->next); + 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; + maybe_protect_ro(header->next); # ifdef PERL_DEBUG_READONLY_COW - header->readonly = 0; + header->readonly = 0; # endif # endif # ifdef MDH_HAS_SIZE - header->size = total_size; + header->size = total_size; # endif - ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); - } + ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); + } #endif - return ptr; + return ptr; } else { #ifndef ALWAYS_NEED_THX - dTHX; + dTHX; #endif - if (PL_nomemok) - return NULL; - croak_no_mem(); + if (PL_nomemok) + return NULL; + croak_no_mem(); } } @@ -886,7 +886,7 @@ Perl_rninstr(const char *big, const char *bigend, const char *little, const char /* A non-existent needle trivially matches the rightmost possible position * in the haystack */ if (UNLIKELY(little_len <= 0)) { - return (char*)bigend; + return (char*)bigend; } /* If the needle is larger than the haystack, the needle can't possibly fit @@ -996,22 +996,22 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) PERL_ARGS_ASSERT_FBM_COMPILE; if (isGV_with_GP(sv) || SvROK(sv)) - return; + return; if (SvVALID(sv)) - return; + return; if (flags & FBMcf_TAIL) { - MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; - sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */ - if (mg && mg->mg_len >= 0) - mg->mg_len++; + MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; + sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */ + if (mg && mg->mg_len >= 0) + mg->mg_len++; } if (!SvPOK(sv) || SvNIOKp(sv)) - s = (U8*)SvPV_force_mutable(sv, len); + 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; + return; SvUPGRADE(sv, SVt_PVMG); SvIOK_off(sv); SvNOK_off(sv); @@ -1023,24 +1023,24 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) assert(mg); if (len > 2) { - /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use - the BM table. */ - const U8 mlen = (len>255) ? 255 : (U8)len; - const unsigned char *const sb = s + len - mlen; /* first char (maybe) */ - U8 *table; - - Newx(table, 256, U8); - memset((void*)table, mlen, 256); - mg->mg_ptr = (char *)table; - mg->mg_len = 256; - - s += len - 1; /* last char */ - i = 0; - while (s >= sb) { - if (table[*s] == mlen) - table[*s] = (U8)i; - s--, i++; - } + /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use + the BM table. */ + const U8 mlen = (len>255) ? 255 : (U8)len; + const unsigned char *const sb = s + len - mlen; /* first char (maybe) */ + U8 *table; + + Newx(table, 256, U8); + memset((void*)table, mlen, 256); + mg->mg_ptr = (char *)table; + mg->mg_len = 256; + + s += len - 1; /* last char */ + i = 0; + while (s >= sb) { + if (table[*s] == mlen) + table[*s] = (U8)i; + s--, i++; + } } BmUSEFUL(sv) = 100; /* Initial value */ @@ -1094,44 +1094,44 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U assert(bigend >= big); if ((STRLEN)(bigend - big) < littlelen) { - if ( tail - && ((STRLEN)(bigend - big) == littlelen - 1) - && (littlelen == 1 - || (*big == *little && - memEQ((char *)big, (char *)little, littlelen - 1)))) - return (char*)big; - return NULL; + if ( tail + && ((STRLEN)(bigend - big) == littlelen - 1) + && (littlelen == 1 + || (*big == *little && + memEQ((char *)big, (char *)little, littlelen - 1)))) + return (char*)big; + return NULL; } switch (littlelen) { /* Special cases for 0, 1 and 2 */ case 0: - return (char*)big; /* Cannot be SvTAIL! */ + return (char*)big; /* Cannot be SvTAIL! */ case 1: - if (tail && !multiline) /* Anchor only! */ - /* [-1] is safe because we know that bigend != big. */ - return (char *) (bigend - (bigend[-1] == '\n')); + if (tail && !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); + s = (unsigned char *)memchr((void*)big, *little, bigend-big); if (s) return (char *)s; - if (tail) - return (char *) bigend; - return NULL; + if (tail) + return (char *) bigend; + return NULL; case 2: - if (tail && !multiline) { + if (tail && !multiline) { /* 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; - } + return (char*)bigend - 2; + if (bigend[-1] == *little) + return (char*)bigend - 1; + 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. @@ -1141,14 +1141,14 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U * 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]; + 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; + s = big; if (c1 != c2) { while (s < bigend) { /* do a quick test for c1 before calling memchr(); @@ -1204,59 +1204,59 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } default: - break; /* Only lengths 0 1 and 2 have special-case code. */ + break; /* Only lengths 0 1 and 2 have special-case code. */ } if (tail && !multiline) { /* tail anchored? */ - s = bigend - littlelen; - if (s >= big && bigend[-1] == '\n' && *s == *little - /* Automatically of length > 2 */ - && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) - { - return (char*)s; /* how sweet it is */ - } - if (s[1] == *little - && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) - { - return (char*)s + 1; /* how sweet it is */ - } - return NULL; + s = bigend - littlelen; + if (s >= big && bigend[-1] == '\n' && *s == *little + /* Automatically of length > 2 */ + && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2)) + { + return (char*)s; /* how sweet it is */ + } + if (s[1] == *little + && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2)) + { + return (char*)s + 1; /* how sweet it is */ + } + return NULL; } if (!valid) { /* not compiled; use Perl_ninstr() instead */ - char * const b = ninstr((char*)big,(char*)bigend, - (char*)little, (char*)little + littlelen); + char * const b = ninstr((char*)big,(char*)bigend, + (char*)little, (char*)little + littlelen); assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */ - return b; + return b; } /* Do actual FBM. */ if (littlelen > (STRLEN)(bigend - big)) - return NULL; + return NULL; { - const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm); - const unsigned char *oldlittle; + const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm); + const unsigned char *oldlittle; - assert(mg); + assert(mg); - --littlelen; /* Last char found by table lookup */ + --littlelen; /* Last char found by table lookup */ - s = big + littlelen; - little += littlelen; /* last char */ - oldlittle = little; - if (s < bigend) { - const unsigned char * const table = (const unsigned char *) mg->mg_ptr; + s = big + littlelen; + little += littlelen; /* last char */ + oldlittle = little; + if (s < bigend) { + const unsigned char * const table = (const unsigned char *) mg->mg_ptr; const unsigned char lastc = *little; - I32 tmp; + I32 tmp; - top2: - if ((tmp = table[*s])) { + top2: + if ((tmp = table[*s])) { /* *s != lastc; earliest position it could match now is * tmp slots further on */ - if ((s += tmp) >= bigend) + if ((s += tmp) >= bigend) goto check_end; if (LIKELY(*s != lastc)) { s++; @@ -1267,35 +1267,35 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } goto top2; } - } + } /* hand-rolled strncmp(): less expensive than calling the * real function (maybe???) */ - { - unsigned char * const olds = s; - - tmp = littlelen; - - while (tmp--) { - if (*--s == *--little) - continue; - s = olds + 1; /* here we pay the price for failure */ - little = oldlittle; - if (s < bigend) /* fake up continue to outer loop */ - goto top2; - goto check_end; - } - return (char *)s; - } - } + { + unsigned char * const olds = s; + + tmp = littlelen; + + while (tmp--) { + if (*--s == *--little) + continue; + s = olds + 1; /* here we pay the price for failure */ + little = oldlittle; + if (s < bigend) /* fake up continue to outer loop */ + goto top2; + goto check_end; + } + return (char *)s; + } + } check_end: - if ( s == bigend - && tail - && memEQ((char *)(bigend - littlelen), - (char *)(oldlittle - littlelen), littlelen) ) - return (char*)bigend - littlelen; - return NULL; + if ( s == bigend + && tail + && memEQ((char *)(bigend - littlelen), + (char *)(oldlittle - littlelen), littlelen) ) + return (char*)bigend - littlelen; + return NULL; } } @@ -1345,12 +1345,12 @@ Perl_savepv(pTHX_ const char *pv) { PERL_UNUSED_CONTEXT; if (!pv) - return NULL; + return NULL; else { - char *newaddr; - const STRLEN pvlen = strlen(pv)+1; - Newx(newaddr, pvlen, char); - return (char*)memcpy(newaddr, pv, pvlen); + char *newaddr; + const STRLEN pvlen = strlen(pv)+1; + Newx(newaddr, pvlen, char); + return (char*)memcpy(newaddr, pv, pvlen); } } @@ -1381,12 +1381,12 @@ Perl_savepvn(pTHX_ const char *pv, Size_t len) Newx(newaddr,len+1,char); /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ if (pv) { - /* might not be null terminated */ - newaddr[len] = '\0'; - return (char *) CopyD(pv,newaddr,len,char); + /* might not be null terminated */ + newaddr[len] = '\0'; + return (char *) CopyD(pv,newaddr,len,char); } else { - return (char *) ZeroD(newaddr,len+1,char); + return (char *) ZeroD(newaddr,len+1,char); } } @@ -1407,12 +1407,12 @@ Perl_savesharedpv(pTHX_ const char *pv) PERL_UNUSED_CONTEXT; if (!pv) - return NULL; + return NULL; pvlen = strlen(pv)+1; newaddr = (char*)PerlMemShared_malloc(pvlen); if (!newaddr) { - croak_no_mem(); + croak_no_mem(); } return (char*)memcpy(newaddr, pv, pvlen); } @@ -1435,7 +1435,7 @@ Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */ if (!newaddr) { - croak_no_mem(); + croak_no_mem(); } newaddr[len] = '\0'; return (char*)memcpy(newaddr, pv, len); @@ -1497,10 +1497,10 @@ S_mess_alloc(pTHX) XPVMG *any; if (PL_phase != PERL_PHASE_DESTRUCT) - return newSVpvs_flags("", SVs_TEMP); + return newSVpvs_flags("", SVs_TEMP); if (PL_mess_sv) - return PL_mess_sv; + return PL_mess_sv; /* Create as PVMG now, to avoid any upgrading later */ Newx(sv, 1, SV); @@ -1626,7 +1626,7 @@ Perl_mess(pTHX_ const char *pat, ...) const COP* Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, - bool opnext) + bool opnext) { /* 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 @@ -1635,27 +1635,27 @@ Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, PERL_ARGS_ASSERT_CLOSEST_COP; if (!o || !curop || ( - opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop + opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop )) - return cop; + return cop; if (o->op_flags & OPf_KIDS) { - const OP *kid; - for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { - const COP *new_cop; + const OP *kid; + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { + const COP *new_cop; - /* If the OP_NEXTSTATE has been optimised away we can still use it - * the get the file and line number. */ + /* If the OP_NEXTSTATE has been optimised away we can still use it + * the get the file and line number. */ - if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) - cop = (const COP *)kid; + if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) + cop = (const COP *)kid; - /* Keep searching, and return when we've found something. */ + /* Keep searching, and return when we've found something. */ - new_cop = closest_cop(cop, kid, curop, opnext); - if (new_cop) - return new_cop; - } + new_cop = closest_cop(cop, kid, curop, opnext); + if (new_cop) + return new_cop; + } } /* Nothing found. */ @@ -1709,31 +1709,31 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) PERL_ARGS_ASSERT_MESS_SV; if (SvROK(basemsg)) { - if (consume) { - sv = basemsg; - } - else { - sv = mess_alloc(); - sv_setsv(sv, basemsg); - } - return sv; + if (consume) { + sv = basemsg; + } + else { + sv = mess_alloc(); + sv_setsv(sv, basemsg); + } + return sv; } if (SvPOK(basemsg) && consume) { - sv = basemsg; + sv = basemsg; } else { - sv = mess_alloc(); - sv_copypv(sv, basemsg); + sv = mess_alloc(); + sv_copypv(sv, basemsg); } if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { - /* - * Try and find the file and line for PL_op. This will usually be - * PL_curcop, but it might be a cop that has been optimised away. We - * can try to find such a cop by searching through the optree starting - * from the sibling of PL_curcop. - */ + /* + * Try and find the file and line for PL_op. This will usually be + * PL_curcop, but it might be a cop that has been optimised away. We + * can try to find such a cop by searching through the optree starting + * from the sibling of PL_curcop. + */ if (PL_curcop) { const COP *cop = @@ -1746,23 +1746,23 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) OutCopFILE(cop), (IV)CopLINE(cop)); } - /* Seems that GvIO() can be untrustworthy during global destruction. */ - if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO) - && IoLINES(GvIOp(PL_last_in_gv))) - { - STRLEN l; - const bool line_mode = (RsSIMPLE(PL_rs) && - *SvPV_const(PL_rs,l) == '\n' && l == 1); - Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf, - SVfARG(PL_last_in_gv == PL_argvgv + /* Seems that GvIO() can be untrustworthy during global destruction. */ + if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO) + && IoLINES(GvIOp(PL_last_in_gv))) + { + STRLEN l; + const bool line_mode = (RsSIMPLE(PL_rs) && + *SvPV_const(PL_rs,l) == '\n' && l == 1); + Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf, + SVfARG(PL_last_in_gv == PL_argvgv ? &PL_sv_no : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))), - line_mode ? "line" : "chunk", - (IV)IoLINES(GvIOp(PL_last_in_gv))); - } - if (PL_phase == PERL_PHASE_DESTRUCT) - sv_catpvs(sv, " during global destruction"); - sv_catpvs(sv, ".\n"); + line_mode ? "line" : "chunk", + (IV)IoLINES(GvIOp(PL_last_in_gv))); + } + if (PL_phase == PERL_PHASE_DESTRUCT) + sv_catpvs(sv, " during global destruction"); + sv_catpvs(sv, ".\n"); } return sv; } @@ -1804,15 +1804,15 @@ Perl_write_to_stderr(pTHX_ SV* msv) PERL_ARGS_ASSERT_WRITE_TO_STDERR; 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, SV_CONST(PRINT), - G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv); + && (io = GvIO(PL_stderrgv)) + && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) + Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT), + G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv); else { - PerlIO * const serr = Perl_error_log; + PerlIO * const serr = Perl_error_log; - do_print(msv, serr); - (void)PerlIO_flush(serr); + do_print(msv, serr); + (void)PerlIO_flush(serr); } } @@ -1827,9 +1827,9 @@ S_with_queued_errors(pTHX_ SV *ex) { PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS; if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) { - sv_catsv(PL_errors, ex); - ex = sv_mortalcopy(PL_errors); - SvCUR_set(PL_errors, 0); + sv_catsv(PL_errors, ex); + ex = sv_mortalcopy(PL_errors); + SvCUR_set(PL_errors, 0); } return ex; } @@ -1845,7 +1845,7 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn) SV * const oldhook = *hook; if (!oldhook || oldhook == PERL_WARNHOOK_FATAL) - return FALSE; + return FALSE; ENTER; SAVESPTR(*hook); @@ -1853,27 +1853,27 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn) cv = sv_2cv(oldhook, &stash, &gv, 0); LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *exarg; - - ENTER; - save_re_context(); - if (warn) { - SAVESPTR(*hook); - *hook = NULL; - } - exarg = newSVsv(ex); - SvREADONLY_on(exarg); - SAVEFREESV(exarg); - - PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK); - PUSHMARK(SP); - XPUSHs(exarg); - PUTBACK; - call_sv(MUTABLE_SV(cv), G_DISCARD); - POPSTACK; - LEAVE; - return TRUE; + dSP; + SV *exarg; + + ENTER; + save_re_context(); + if (warn) { + SAVESPTR(*hook); + *hook = NULL; + } + exarg = newSVsv(ex); + SvREADONLY_on(exarg); + SAVEFREESV(exarg); + + PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK); + PUSHMARK(SP); + XPUSHs(exarg); + PUTBACK; + call_sv(MUTABLE_SV(cv), G_DISCARD); + POPSTACK; + LEAVE; + return TRUE; } return FALSE; } @@ -2144,7 +2144,7 @@ Perl_warn_sv(pTHX_ SV *baseex) SV *ex = mess_sv(baseex, 0); PERL_ARGS_ASSERT_WARN_SV; if (!invoke_exception_hook(ex, TRUE)) - write_to_stderr(ex); + write_to_stderr(ex); } /* @@ -2166,7 +2166,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) SV *ex = vmess(pat, args); PERL_ARGS_ASSERT_VWARN; if (!invoke_exception_hook(ex, TRUE)) - write_to_stderr(ex); + write_to_stderr(ex); } /* @@ -2283,10 +2283,10 @@ Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...) PERL_ARGS_ASSERT_CK_WARNER_D; if (Perl_ckwarn_d(aTHX_ err)) { - va_list args; - va_start(args, pat); - vwarner(err, pat, &args); - va_end(args); + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); } } @@ -2296,10 +2296,10 @@ Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) PERL_ARGS_ASSERT_CK_WARNER; if (Perl_ckwarn(aTHX_ err)) { - va_list args; - va_start(args, pat); - vwarner(err, pat, &args); - va_end(args); + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); } } @@ -2321,18 +2321,18 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) && !(PL_in_eval & EVAL_KEEPERR) ) { - SV * const msv = vmess(pat, args); + SV * const msv = vmess(pat, args); - if (PL_parser && PL_parser->error_count) { - qerror(msv); - } - else { - invoke_exception_hook(msv, FALSE); - die_unwind(msv); - } + if (PL_parser && PL_parser->error_count) { + qerror(msv); + } + else { + invoke_exception_hook(msv, FALSE); + die_unwind(msv); + } } else { - Perl_vwarn(aTHX_ pat, args); + Perl_vwarn(aTHX_ pat, args); } } @@ -2343,7 +2343,7 @@ Perl_ckwarn(pTHX_ U32 w) { /* If lexical warnings have not been set, use $^W. */ if (isLEXWARN_off) - return PL_dowarn & G_WARN_ON; + return PL_dowarn & G_WARN_ON; return ckwarn_common(w); } @@ -2355,7 +2355,7 @@ Perl_ckwarn_d(pTHX_ U32 w) { /* If lexical warnings have not been set then default classes warn. */ if (isLEXWARN_off) - return TRUE; + return TRUE; return ckwarn_common(w); } @@ -2364,10 +2364,10 @@ static bool S_ckwarn_common(pTHX_ U32 w) { if (PL_curcop->cop_warnings == pWARN_ALL) - return TRUE; + return TRUE; if (PL_curcop->cop_warnings == pWARN_NONE) - return FALSE; + return FALSE; /* Check the assumption that at least the first slot is non-zero. */ assert(unpackWARN1(w)); @@ -2375,17 +2375,17 @@ S_ckwarn_common(pTHX_ U32 w) /* Check the assumption that it is valid to stop as soon as a zero slot is seen. */ if (!unpackWARN2(w)) { - assert(!unpackWARN3(w)); - assert(!unpackWARN4(w)); + assert(!unpackWARN3(w)); + assert(!unpackWARN4(w)); } else if (!unpackWARN3(w)) { - assert(!unpackWARN4(w)); + assert(!unpackWARN4(w)); } - + /* Right, dealt with all the special cases, which are implemented as non- pointers, so there is a pointer to a real warnings mask. */ do { - if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))) - return TRUE; + if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))) + return TRUE; } while (w >>= WARNshift); return FALSE; @@ -2394,20 +2394,20 @@ S_ckwarn_common(pTHX_ U32 w) /* Set buffer=NULL to get a new one. */ STRLEN * Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, - STRLEN size) { + STRLEN size) { const MEM_SIZE len_wanted = - sizeof(STRLEN) + (size > WARNsize ? size : WARNsize); + sizeof(STRLEN) + (size > WARNsize ? size : WARNsize); PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD; buffer = (STRLEN*) - (specialWARN(buffer) ? - PerlMemShared_malloc(len_wanted) : - PerlMemShared_realloc(buffer, len_wanted)); + (specialWARN(buffer) ? + PerlMemShared_malloc(len_wanted) : + PerlMemShared_realloc(buffer, len_wanted)); buffer[0] = size; Copy(bits, (buffer + 1), size, char); if (size < WARNsize) - Zero((char *)(buffer + 1) + size, WARNsize - size, char); + Zero((char *)(buffer + 1) + size, WARNsize - size, char); return buffer; } @@ -2572,9 +2572,9 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) if (environ) /* old glibc can crash with null environ */ (void)unsetenv(nam); } else { - const Size_t nlen = strlen(nam); - const Size_t vlen = strlen(val); - char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1); + const Size_t nlen = strlen(nam); + const Size_t vlen = strlen(val); + char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1); my_setenv_format(new_env, nam, nlen, val, vlen); (void)putenv(new_env); } @@ -2582,10 +2582,10 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) # else /* ! HAS_UNSETENV */ char *new_env; - const Size_t nlen = strlen(nam); - Size_t vlen; + const Size_t nlen = strlen(nam); + Size_t vlen; if (!val) { - val = ""; + val = ""; } vlen = strlen(val); new_env = S_env_alloc(NULL, nlen, vlen, 2, 1); @@ -2641,7 +2641,7 @@ Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ PERL_ARGS_ASSERT_UNLNK; while (PerlLIO_unlink(f) >= 0) - retries++; + retries++; return retries ? 0 : -1; } #endif @@ -2663,77 +2663,77 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) This = (*mode == 'w'); that = !This; if (TAINTING_get) { - taint_env(); - taint_proper("Insecure %s%s", "EXEC"); + taint_env(); + taint_proper("Insecure %s%s", "EXEC"); } if (PerlProc_pipe_cloexec(p) < 0) - return NULL; + return NULL; /* Try for another pipe pair for error return */ if (PerlProc_pipe_cloexec(pp) >= 0) - did_pipes = 1; + did_pipes = 1; while ((pid = PerlProc_fork()) < 0) { - if (errno != EAGAIN) { - PerlLIO_close(p[This]); - PerlLIO_close(p[that]); - if (did_pipes) { - PerlLIO_close(pp[0]); - PerlLIO_close(pp[1]); - } - return NULL; - } - Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); - sleep(5); + if (errno != EAGAIN) { + PerlLIO_close(p[This]); + PerlLIO_close(p[that]); + if (did_pipes) { + PerlLIO_close(pp[0]); + PerlLIO_close(pp[1]); + } + return NULL; + } + Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); + sleep(5); } if (pid == 0) { - /* Child */ + /* Child */ #undef THIS #undef THAT #define THIS that #define THAT This - /* Close parent's end of error status pipe (if any) */ - if (did_pipes) - PerlLIO_close(pp[0]); - /* Now dup our end of _the_ pipe to right position */ - if (p[THIS] != (*mode == 'r')) { - PerlLIO_dup2(p[THIS], *mode == 'r'); - PerlLIO_close(p[THIS]); - if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ - PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ - } - else { - setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]); - PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ + /* Close parent's end of error status pipe (if any) */ + if (did_pipes) + PerlLIO_close(pp[0]); + /* Now dup our end of _the_ pipe to right position */ + if (p[THIS] != (*mode == 'r')) { + PerlLIO_dup2(p[THIS], *mode == 'r'); + PerlLIO_close(p[THIS]); + if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ + PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ + } + else { + setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]); + PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */ } #if !defined(HAS_FCNTL) || !defined(F_SETFD) - /* No automatic close - do it by hand */ + /* No automatic close - do it by hand */ # ifndef NOFILE # define NOFILE 20 # endif - { - int fd; + { + int fd; - for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { - if (fd != pp[1]) - PerlLIO_close(fd); - } - } + for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { + if (fd != pp[1]) + PerlLIO_close(fd); + } + } #endif - do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes); - PerlProc__exit(1); + do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes); + PerlProc__exit(1); #undef THIS #undef THAT } /* Parent */ if (did_pipes) - PerlLIO_close(pp[1]); + PerlLIO_close(pp[1]); /* Keep the lower of the two fd numbers */ if (p[that] < p[This]) { - PerlLIO_dup2_cloexec(p[This], p[that]); - PerlLIO_close(p[This]); - p[This] = p[that]; + PerlLIO_dup2_cloexec(p[This], p[that]); + PerlLIO_close(p[This]); + p[This] = p[that]; } else - PerlLIO_close(p[that]); /* close child's end of pipe */ + PerlLIO_close(p[that]); /* close child's end of pipe */ sv = *av_fetch(PL_fdpid,p[This],TRUE); SvUPGRADE(sv,SVt_IV); @@ -2741,33 +2741,33 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) PL_forkprocess = pid; /* If we managed to get status pipe check for exec fail */ if (did_pipes && pid > 0) { - int errkid; - unsigned read_total = 0; + int errkid; + unsigned read_total = 0; - while (read_total < sizeof(int)) { + while (read_total < sizeof(int)) { const SSize_t n1 = PerlLIO_read(pp[0], - (void*)(((char*)&errkid)+read_total), - (sizeof(int)) - read_total); - if (n1 <= 0) - break; - read_total += n1; - } - PerlLIO_close(pp[0]); - did_pipes = 0; - if (read_total) { /* Error */ - int pid2, status; - PerlLIO_close(p[This]); - if (read_total != sizeof(int)) - Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", read_total); - do { - pid2 = wait4pid(pid, &status, 0); - } while (pid2 == -1 && errno == EINTR); - errno = errkid; /* Propagate errno from kid */ - return NULL; - } + (void*)(((char*)&errkid)+read_total), + (sizeof(int)) - read_total); + if (n1 <= 0) + break; + read_total += n1; + } + PerlLIO_close(pp[0]); + did_pipes = 0; + if (read_total) { /* Error */ + int pid2, status; + PerlLIO_close(p[This]); + if (read_total != sizeof(int)) + Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", read_total); + do { + pid2 = wait4pid(pid, &status, 0); + } while (pid2 == -1 && errno == EINTR); + errno = errkid; /* Propagate errno from kid */ + return NULL; + } } if (did_pipes) - PerlLIO_close(pp[0]); + PerlLIO_close(pp[0]); return PerlIO_fdopen(p[This], mode); #else # if defined(OS2) /* Same, without fork()ing and all extra overhead... */ @@ -2799,33 +2799,33 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) PERL_FLUSHALL_FOR_CHILD; #ifdef OS2 if (doexec) { - return my_syspopen(aTHX_ cmd,mode); + return my_syspopen(aTHX_ cmd,mode); } #endif This = (*mode == 'w'); that = !This; if (doexec && TAINTING_get) { - taint_env(); - taint_proper("Insecure %s%s", "EXEC"); + taint_env(); + taint_proper("Insecure %s%s", "EXEC"); } if (PerlProc_pipe_cloexec(p) < 0) - return NULL; + return NULL; if (doexec && PerlProc_pipe_cloexec(pp) >= 0) - did_pipes = 1; + did_pipes = 1; while ((pid = PerlProc_fork()) < 0) { - if (errno != EAGAIN) { - PerlLIO_close(p[This]); - PerlLIO_close(p[that]); - if (did_pipes) { - PerlLIO_close(pp[0]); - PerlLIO_close(pp[1]); - } - if (!doexec) - Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); - return NULL; - } - Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); - sleep(5); + if (errno != EAGAIN) { + PerlLIO_close(p[This]); + PerlLIO_close(p[that]); + if (did_pipes) { + PerlLIO_close(pp[0]); + PerlLIO_close(pp[1]); + } + if (!doexec) + Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); + return NULL; + } + Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); + sleep(5); } if (pid == 0) { @@ -2833,36 +2833,36 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) #undef THAT #define THIS that #define THAT This - if (did_pipes) - PerlLIO_close(pp[0]); - if (p[THIS] != (*mode == 'r')) { - PerlLIO_dup2(p[THIS], *mode == 'r'); - PerlLIO_close(p[THIS]); - if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ - PerlLIO_close(p[THAT]); - } - else { - setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]); - PerlLIO_close(p[THAT]); - } + if (did_pipes) + PerlLIO_close(pp[0]); + if (p[THIS] != (*mode == 'r')) { + PerlLIO_dup2(p[THIS], *mode == 'r'); + PerlLIO_close(p[THIS]); + if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */ + PerlLIO_close(p[THAT]); + } + else { + setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]); + PerlLIO_close(p[THAT]); + } #ifndef OS2 - if (doexec) { + if (doexec) { #if !defined(HAS_FCNTL) || !defined(F_SETFD) #ifndef NOFILE #define NOFILE 20 #endif - { - int fd; + { + int fd; - for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) - if (fd != pp[1]) - PerlLIO_close(fd); - } + for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) + if (fd != pp[1]) + PerlLIO_close(fd); + } #endif - /* may or may not use the shell */ - do_exec3(cmd, pp[1], did_pipes); - PerlProc__exit(1); - } + /* may or may not use the shell */ + do_exec3(cmd, pp[1], did_pipes); + PerlProc__exit(1); + } #endif /* defined OS2 */ #ifdef PERLIO_USING_CRLF @@ -2871,56 +2871,56 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) default, binary, low-level mode; see PerlIOBuf_open(). */ PerlLIO_setmode((*mode == 'r'), O_BINARY); #endif - PL_forkprocess = 0; + PL_forkprocess = 0; #ifdef PERL_USES_PL_PIDSTATUS - hv_clear(PL_pidstatus); /* we have no children */ + hv_clear(PL_pidstatus); /* we have no children */ #endif - return NULL; + return NULL; #undef THIS #undef THAT } if (did_pipes) - PerlLIO_close(pp[1]); + PerlLIO_close(pp[1]); if (p[that] < p[This]) { - PerlLIO_dup2_cloexec(p[This], p[that]); - PerlLIO_close(p[This]); - p[This] = p[that]; + PerlLIO_dup2_cloexec(p[This], p[that]); + PerlLIO_close(p[This]); + p[This] = p[that]; } else - PerlLIO_close(p[that]); + PerlLIO_close(p[that]); sv = *av_fetch(PL_fdpid,p[This],TRUE); SvUPGRADE(sv,SVt_IV); SvIV_set(sv, pid); PL_forkprocess = pid; if (did_pipes && pid > 0) { - int errkid; - unsigned n = 0; + int errkid; + unsigned n = 0; - while (n < sizeof(int)) { + while (n < sizeof(int)) { const SSize_t n1 = PerlLIO_read(pp[0], - (void*)(((char*)&errkid)+n), - (sizeof(int)) - n); - if (n1 <= 0) - break; - n += n1; - } - PerlLIO_close(pp[0]); - did_pipes = 0; - if (n) { /* Error */ - int pid2, status; - PerlLIO_close(p[This]); - if (n != sizeof(int)) - Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); - do { - pid2 = wait4pid(pid, &status, 0); - } while (pid2 == -1 && errno == EINTR); - errno = errkid; /* Propagate errno from kid */ - return NULL; - } + (void*)(((char*)&errkid)+n), + (sizeof(int)) - n); + if (n1 <= 0) + break; + n += n1; + } + PerlLIO_close(pp[0]); + did_pipes = 0; + if (n) { /* Error */ + int pid2, status; + PerlLIO_close(p[This]); + if (n != sizeof(int)) + Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); + do { + pid2 = wait4pid(pid, &status, 0); + } while (pid2 == -1 && errno == EINTR); + errno = errkid; /* Propagate errno from kid */ + return NULL; + } } if (did_pipes) - PerlLIO_close(pp[0]); + PerlLIO_close(pp[0]); return PerlIO_fdopen(p[This], mode); } #elif defined(DJGPP) @@ -3024,7 +3024,7 @@ dup2(int oldfd, int newfd) { #if defined(HAS_FCNTL) && defined(F_DUPFD) if (oldfd == newfd) - return oldfd; + return oldfd; PerlLIO_close(newfd); return fcntl(oldfd, F_DUPFD, newfd); #else @@ -3034,19 +3034,19 @@ dup2(int oldfd, int newfd) int fd; if (oldfd == newfd) - return oldfd; + return oldfd; PerlLIO_close(newfd); /* good enough for low fd's... */ while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) { - if (fdx >= DUP2_MAX_FDS) { - PerlLIO_close(fd); - fd = -1; - break; - } - fdtmp[fdx++] = fd; + if (fdx >= DUP2_MAX_FDS) { + PerlLIO_close(fd); + fd = -1; + break; + } + fdtmp[fdx++] = fd; } while (fdx > 0) - PerlLIO_close(fdtmp[--fdx]); + PerlLIO_close(fdtmp[--fdx]); return fd; #endif } @@ -3073,7 +3073,7 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return (Sighandler_t) SIG_ERR; + return (Sighandler_t) SIG_ERR; #endif act.sa_handler = handler; @@ -3085,12 +3085,12 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) #endif #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) - act.sa_flags |= SA_NOCLDWAIT; + act.sa_flags |= SA_NOCLDWAIT; #endif if (sigaction(signo, &act, &oact) == -1) - return (Sighandler_t) SIG_ERR; + return (Sighandler_t) SIG_ERR; else - return (Sighandler_t) oact.sa_handler; + return (Sighandler_t) oact.sa_handler; } Sighandler_t @@ -3100,9 +3100,9 @@ Perl_rsignal_state(pTHX_ int signo) PERL_UNUSED_CONTEXT; if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) - return (Sighandler_t) SIG_ERR; + return (Sighandler_t) SIG_ERR; else - return (Sighandler_t) oact.sa_handler; + return (Sighandler_t) oact.sa_handler; } int @@ -3115,7 +3115,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return -1; + return -1; #endif act.sa_handler = handler; @@ -3127,7 +3127,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) #endif #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) - act.sa_flags |= SA_NOCLDWAIT; + act.sa_flags |= SA_NOCLDWAIT; #endif return sigaction(signo, &act, save); } @@ -3139,7 +3139,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return -1; + return -1; #endif return sigaction(signo, save, (struct sigaction *)NULL); @@ -3153,7 +3153,7 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return (Sighandler_t) SIG_ERR; + return (Sighandler_t) SIG_ERR; #endif return PerlProc_signal(signo, handler); @@ -3173,14 +3173,14 @@ Perl_rsignal_state(pTHX_ int signo) #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return (Sighandler_t) SIG_ERR; + return (Sighandler_t) SIG_ERR; #endif PL_sig_trapped = 0; oldsig = PerlProc_signal(signo, sig_trap); PerlProc_signal(signo, oldsig); if (PL_sig_trapped) - PerlProc_kill(PerlProc_getpid(), signo); + PerlProc_kill(PerlProc_getpid(), signo); return oldsig; } @@ -3190,7 +3190,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return -1; + return -1; #endif *save = PerlProc_signal(signo, handler); return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0; @@ -3202,7 +3202,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return -1; + return -1; #endif return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0; } @@ -3239,17 +3239,17 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #ifdef OS2 if (pid == -1) { /* Opened by popen. */ - return my_syspclose(ptr); + return my_syspclose(ptr); } #endif close_failed = (PerlIO_close(ptr) == EOF); SAVE_ERRNO; if (should_wait) do { - pid2 = wait4pid(pid, &status, 0); + pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); if (close_failed) { - RESTORE_ERRNO; - return -1; + RESTORE_ERRNO; + return -1; } return( should_wait @@ -3282,46 +3282,46 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) return -1; } { - if (pid > 0) { - /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the - pid, rather than a string form. */ - SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE); - if (svp && *svp != &PL_sv_undef) { - *statusp = SvIVX(*svp); - (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t), - G_DISCARD); - return pid; - } - } - else { - HE *entry; - - hv_iterinit(PL_pidstatus); - if ((entry = hv_iternext(PL_pidstatus))) { - SV * const sv = hv_iterval(PL_pidstatus,entry); - I32 len; - const char * const spid = hv_iterkey(entry,&len); - - assert (len == sizeof(Pid_t)); - memcpy((char *)&pid, spid, len); - *statusp = SvIVX(sv); - /* The hash iterator is currently on this entry, so simply - calling hv_delete would trigger the lazy delete, which on - aggregate does more work, because next call to hv_iterinit() - would spot the flag, and have to call the delete routine, - while in the meantime any new entries can't re-use that - memory. */ - hv_iterinit(PL_pidstatus); - (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD); - return pid; - } - } + if (pid > 0) { + /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the + pid, rather than a string form. */ + SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE); + if (svp && *svp != &PL_sv_undef) { + *statusp = SvIVX(*svp); + (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t), + G_DISCARD); + return pid; + } + } + else { + HE *entry; + + hv_iterinit(PL_pidstatus); + if ((entry = hv_iternext(PL_pidstatus))) { + SV * const sv = hv_iterval(PL_pidstatus,entry); + I32 len; + const char * const spid = hv_iterkey(entry,&len); + + assert (len == sizeof(Pid_t)); + memcpy((char *)&pid, spid, len); + *statusp = SvIVX(sv); + /* The hash iterator is currently on this entry, so simply + calling hv_delete would trigger the lazy delete, which on + aggregate does more work, because next call to hv_iterinit() + would spot the flag, and have to call the delete routine, + while in the meantime any new entries can't re-use that + memory. */ + hv_iterinit(PL_pidstatus); + (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD); + return pid; + } + } } #endif #ifdef HAS_WAITPID # ifdef HAS_WAITPID_RUNTIME if (!HAS_WAITPID_RUNTIME) - goto hard_way; + goto hard_way; # endif result = PerlProc_waitpid(pid,statusp,flags); goto finish; @@ -3335,22 +3335,22 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) hard_way: #endif { - if (flags) - Perl_croak(aTHX_ "Can't do waitpid with flags"); - else { - while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) - pidgone(result,*statusp); - if (result < 0) - *statusp = -1; - } + if (flags) + Perl_croak(aTHX_ "Can't do waitpid with flags"); + else { + while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0) + pidgone(result,*statusp); + if (result < 0) + *statusp = -1; + } } #endif #if defined(HAS_WAITPID) || defined(HAS_WAIT4) finish: #endif if (result < 0 && errno == EINTR) { - PERL_ASYNC_CHECK(); - errno = EINTR; /* reset in case a signal handler changed $! */ + PERL_ASYNC_CHECK(); + errno = EINTR; /* reset in case a signal handler changed $! */ } return result; } @@ -3373,7 +3373,7 @@ S_pidgone(pTHX_ Pid_t pid, int status) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 - in os2ish.h. */ + in os2ish.h. */ my_syspclose(PerlIO *ptr) #else I32 @@ -3411,32 +3411,32 @@ Perl_repeatcpy(char *to, const char *from, I32 len, IV count) assert(len >= 0); if (count < 0) - croak_memory_wrap(); + croak_memory_wrap(); if (len == 1) - memset(to, *from, count); + memset(to, *from, count); else if (count) { - char *p = to; - IV items, linear, half; - - linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR; - for (items = 0; items < linear; ++items) { - const char *q = from; - IV todo; - for (todo = len; todo > 0; todo--) - *p++ = *q++; + char *p = to; + IV items, linear, half; + + linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR; + for (items = 0; items < linear; ++items) { + const char *q = from; + IV todo; + for (todo = len; todo > 0; todo--) + *p++ = *q++; } - half = count / 2; - while (items <= half) { - IV size = items * len; - memcpy(p, to, size); - p += size; - items *= 2; - } + half = count / 2; + while (items <= half) { + IV size = items * len; + memcpy(p, to, size); + p += size; + items *= 2; + } - if (count > items) - memcpy(p, to, (count - items) * len); + if (count > items) + memcpy(p, to, (count - items) * len); } } @@ -3453,35 +3453,35 @@ Perl_same_dirent(pTHX_ const char *a, const char *b) PERL_ARGS_ASSERT_SAME_DIRENT; if (fa) - fa++; + fa++; else - fa = a; + fa = a; if (fb) - fb++; + fb++; else - fb = b; + fb = b; if (strNE(a,b)) - return FALSE; + return FALSE; if (fa == a) - sv_setpvs(tmpsv, "."); + sv_setpvs(tmpsv, "."); else - sv_setpvn(tmpsv, a, fa - a); + sv_setpvn(tmpsv, a, fa - a); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) - return FALSE; + return FALSE; if (fb == b) - sv_setpvs(tmpsv, "."); + sv_setpvs(tmpsv, "."); else - sv_setpvn(tmpsv, b, fb - b); + sv_setpvn(tmpsv, b, fb - b); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) - return FALSE; + return FALSE; return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && - tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; + tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; } #endif /* !HAS_RENAME */ char* Perl_find_script(pTHX_ const char *scriptname, bool dosearch, - const char *const *const search_ext, I32 flags) + const char *const *const search_ext, I32 flags) { const char *xfound = NULL; char *xfailed = NULL; @@ -3539,169 +3539,169 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, # ifdef ALWAYS_DEFTYPES len = strlen(scriptname); if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { - int idx = 0, deftypes = 1; - bool seen_dot = 1; + int idx = 0, deftypes = 1; + bool seen_dot = 1; - const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL); + const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL); # else if (dosearch) { - int idx = 0, deftypes = 1; - bool seen_dot = 1; + int idx = 0, deftypes = 1; + bool seen_dot = 1; - const int hasdir = (strpbrk(scriptname,":[</") != NULL); + const int hasdir = (strpbrk(scriptname,":[</") != NULL); # endif - /* The first time through, just add SEARCH_EXTS to whatever we - * already have, so we can check for default file types. */ - while (deftypes || - (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) - { - Stat_t statbuf; - if (deftypes) { - deftypes = 0; - *tmpbuf = '\0'; - } - if ((strlen(tmpbuf) + strlen(scriptname) - + MAX_EXT_LEN) >= sizeof tmpbuf) - continue; /* don't search dir with too-long name */ - my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf)); + /* The first time through, just add SEARCH_EXTS to whatever we + * already have, so we can check for default file types. */ + while (deftypes || + (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) + { + Stat_t statbuf; + if (deftypes) { + deftypes = 0; + *tmpbuf = '\0'; + } + if ((strlen(tmpbuf) + strlen(scriptname) + + MAX_EXT_LEN) >= sizeof tmpbuf) + continue; /* don't search dir with too-long name */ + my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf)); #else /* !VMS */ #ifdef DOSISH if (strEQ(scriptname, "-")) - dosearch = 0; + dosearch = 0; if (dosearch) { /* Look in '.' first. */ - const char *cur = scriptname; + const char *cur = scriptname; #ifdef SEARCH_EXTS - if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ - while (ext[i]) - if (strEQ(ext[i++],curext)) { - extidx = -1; /* already has an ext */ - break; - } - do { -#endif - DEBUG_p(PerlIO_printf(Perl_debug_log, - "Looking for %s\n",cur)); - { - Stat_t statbuf; - if (PerlLIO_stat(cur,&statbuf) >= 0 - && !S_ISDIR(statbuf.st_mode)) { - dosearch = 0; - scriptname = cur; + if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ + while (ext[i]) + if (strEQ(ext[i++],curext)) { + extidx = -1; /* already has an ext */ + break; + } + do { +#endif + DEBUG_p(PerlIO_printf(Perl_debug_log, + "Looking for %s\n",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) { - len = strlen(scriptname); - if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) - break; - my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf)); - cur = tmpbuf; - } - } while (extidx >= 0 && ext[extidx] /* try an extension? */ - && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)); + if (cur == scriptname) { + len = strlen(scriptname); + if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) + break; + my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf)); + cur = tmpbuf; + } + } while (extidx >= 0 && ext[extidx] /* try an extension? */ + && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)); #endif } #endif if (dosearch && !strchr(scriptname, '/') #ifdef DOSISH - && !strchr(scriptname, '\\') + && !strchr(scriptname, '\\') #endif - && (s = PerlEnv_getenv("PATH"))) + && (s = PerlEnv_getenv("PATH"))) { - bool seen_dot = 0; + bool seen_dot = 0; - bufend = s + strlen(s); - while (s < bufend) { - Stat_t statbuf; + bufend = s + strlen(s); + while (s < bufend) { + Stat_t statbuf; # ifdef DOSISH - for (len = 0; *s - && *s != ';'; len++, s++) { - if (len < sizeof tmpbuf) - tmpbuf[len] = *s; - } - if (len < sizeof tmpbuf) - tmpbuf[len] = '\0'; + for (len = 0; *s + && *s != ';'; len++, s++) { + if (len < sizeof tmpbuf) + tmpbuf[len] = *s; + } + if (len < sizeof tmpbuf) + tmpbuf[len] = '\0'; # else - s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, + s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, ':', &len); # endif - if (s < bufend) - s++; - if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) - continue; /* don't search dir with too-long name */ - if (len + if (s < bufend) + s++; + if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) + continue; /* don't search dir with too-long name */ + if (len # ifdef DOSISH - && tmpbuf[len - 1] != '/' - && tmpbuf[len - 1] != '\\' + && tmpbuf[len - 1] != '/' + && tmpbuf[len - 1] != '\\' # endif - ) - tmpbuf[len++] = '/'; - if (len == 2 && tmpbuf[0] == '.') - seen_dot = 1; - (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len); + ) + tmpbuf[len++] = '/'; + if (len == 2 && tmpbuf[0] == '.') + seen_dot = 1; + (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len); #endif /* !VMS */ #ifdef SEARCH_EXTS - len = strlen(tmpbuf); - if (extidx > 0) /* reset after previous loop */ - extidx = 0; - do { -#endif - DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); - retval = PerlLIO_stat(tmpbuf,&statbuf); - if (S_ISDIR(statbuf.st_mode)) { - retval = -1; - } + len = strlen(tmpbuf); + if (extidx > 0) /* reset after previous loop */ + extidx = 0; + do { +#endif + DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); + retval = PerlLIO_stat(tmpbuf,&statbuf); + if (S_ISDIR(statbuf.st_mode)) { + retval = -1; + } #ifdef SEARCH_EXTS - } while ( retval < 0 /* not there */ - && extidx>=0 && ext[extidx] /* try an extension? */ - && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len) - ); -#endif - if (retval < 0) - continue; - if (S_ISREG(statbuf.st_mode) - && cando(S_IRUSR,TRUE,&statbuf) + } while ( retval < 0 /* not there */ + && extidx>=0 && ext[extidx] /* try an extension? */ + && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len) + ); +#endif + if (retval < 0) + continue; + if (S_ISREG(statbuf.st_mode) + && cando(S_IRUSR,TRUE,&statbuf) #if !defined(DOSISH) - && cando(S_IXUSR,TRUE,&statbuf) -#endif - ) - { - xfound = tmpbuf; /* bingo! */ - break; - } - if (!xfailed) - xfailed = savepv(tmpbuf); - } + && cando(S_IXUSR,TRUE,&statbuf) +#endif + ) + { + xfound = tmpbuf; /* bingo! */ + break; + } + if (!xfailed) + xfailed = savepv(tmpbuf); + } #ifndef DOSISH - { - Stat_t statbuf; - if (!xfound && !seen_dot && !xfailed && - (PerlLIO_stat(scriptname,&statbuf) < 0 - || S_ISDIR(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. */ + seen_dot = 1; /* Disable message. */ #ifndef DOSISH - } -#endif - if (!xfound) { - if (flags & 1) { /* do or die? */ - /* diag_listed_as: Can't execute %s */ - Perl_croak(aTHX_ "Can't %s %s%s%s", - (xfailed ? "execute" : "find"), - (xfailed ? xfailed : scriptname), - (xfailed ? "" : " on PATH"), - (xfailed || seen_dot) ? "" : ", '.' not in PATH"); - } - scriptname = NULL; - } - Safefree(xfailed); - scriptname = xfound; + } +#endif + if (!xfound) { + if (flags & 1) { /* do or die? */ + /* diag_listed_as: Can't execute %s */ + Perl_croak(aTHX_ "Can't %s %s%s%s", + (xfailed ? "execute" : "find"), + (xfailed ? xfailed : scriptname), + (xfailed ? "" : " on PATH"), + (xfailed || seen_dot) ? "" : ", '.' not in PATH"); + } + scriptname = NULL; + } + Safefree(xfailed); + scriptname = xfound; } return (scriptname ? savepv(scriptname) : NULL); } @@ -3716,7 +3716,7 @@ Perl_get_context(void) pthread_addr_t t; int error = pthread_getspecific(PL_thr_key, &t); if (error) - Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error); + Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error); return (void*)t; # elif defined(I_MACH_CTHREADS) return (void*)cthread_data(cthread_self()); @@ -3739,9 +3739,9 @@ Perl_set_context(void *t) cthread_set_data(cthread_self(), t); # else { - const int error = pthread_setspecific(PL_thr_key, t); - if (error) - Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error); + const int error = pthread_setspecific(PL_thr_key, t); + if (error) + Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error); } # endif #else @@ -3794,7 +3794,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_GETENV_LEN; if (env_trans) - *len = strlen(env_trans); + *len = strlen(env_trans); return env_trans; } #endif @@ -3806,7 +3806,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) PERL_UNUSED_CONTEXT; return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) - ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id; + ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id; } I32 @@ -3838,10 +3838,10 @@ Perl_my_fflush_all(pTHX) if (open_max > 0) { long i; for (i = 0; i < open_max; i++) - if (STDIO_STREAM_ARRAY[i]._file >= 0 && - STDIO_STREAM_ARRAY[i]._file < open_max && - STDIO_STREAM_ARRAY[i]._flag) - PerlIO_flush(&STDIO_STREAM_ARRAY[i]); + if (STDIO_STREAM_ARRAY[i]._file >= 0 && + STDIO_STREAM_ARRAY[i]._file < open_max && + STDIO_STREAM_ARRAY[i]._flag) + PerlIO_flush(&STDIO_STREAM_ARRAY[i]); return 0; } # endif @@ -3859,15 +3859,15 @@ Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) = gv && (isGV_with_GP(gv)) ? GvENAME_HEK((gv)) : NULL; - const char * const direction = have == '>' ? "out" : "in"; + const char * const direction = have == '>' ? "out" : "in"; - if (name && HEK_LEN(name)) - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %" HEKf " opened only for %sput", - HEKfARG(name), direction); - else - Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle opened only for %sput", direction); + if (name && HEK_LEN(name)) + Perl_warner(aTHX_ packWARN(WARN_IO), + "Filehandle %" HEKf " opened only for %sput", + HEKfARG(name), direction); + else + Perl_warner(aTHX_ packWARN(WARN_IO), + "Filehandle opened only for %sput", direction); } } @@ -3880,42 +3880,42 @@ Perl_report_evil_fh(pTHX_ const GV *gv) I32 warn_type; if (io && IoTYPE(io) == IoTYPE_CLOSED) { - vile = "closed"; - warn_type = WARN_CLOSED; + vile = "closed"; + warn_type = WARN_CLOSED; } else { - vile = "unopened"; - warn_type = WARN_UNOPENED; + vile = "unopened"; + warn_type = WARN_UNOPENED; } if (ckWARN(warn_type)) { SV * const name = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ? sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL; - const char * const pars = - (const char *)(OP_IS_FILETEST(op) ? "" : "()"); - const char * const func = - (const char *) - (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 = - (const char *) - (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) - ? "socket" : "filehandle"); - const bool have_name = name && SvCUR(name); - Perl_warner(aTHX_ packWARN(warn_type), - "%s%s on %s %s%s%" SVf, func, pars, vile, type, - have_name ? " " : "", - SVfARG(have_name ? name : &PL_sv_no)); - if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) - Perl_warner( - aTHX_ packWARN(warn_type), - "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n", - func, pars, have_name ? " " : "", - SVfARG(have_name ? name : &PL_sv_no) - ); + const char * const pars = + (const char *)(OP_IS_FILETEST(op) ? "" : "()"); + const char * const func = + (const char *) + (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 = + (const char *) + (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) + ? "socket" : "filehandle"); + const bool have_name = name && SvCUR(name); + Perl_warner(aTHX_ packWARN(warn_type), + "%s%s on %s %s%s%" SVf, func, pars, vile, type, + have_name ? " " : "", + SVfARG(have_name ? name : &PL_sv_no)); + if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + Perl_warner( + aTHX_ packWARN(warn_type), + "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n", + func, pars, have_name ? " " : "", + SVfARG(have_name ? name : &PL_sv_no) + ); } } @@ -4061,9 +4061,9 @@ Perl_mini_mktime(struct tm *ptm) mday = ptm->tm_mday; jday = 0; if (month >= 2) - month+=2; + month+=2; else - month+=14, year--; + month+=14, year--; yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; yearday += month*MONTH_TO_DAYS + mday + jday; /* @@ -4073,29 +4073,29 @@ Perl_mini_mktime(struct tm *ptm) * be rationalised, however. */ if ((unsigned) ptm->tm_sec <= 60) { - secs = 0; + secs = 0; } else { - secs = ptm->tm_sec; - ptm->tm_sec = 0; + secs = ptm->tm_sec; + ptm->tm_sec = 0; } secs += 60 * ptm->tm_min; secs += SECS_PER_HOUR * ptm->tm_hour; if (secs < 0) { - if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { - /* got negative remainder, but need positive time */ - /* back off an extra day to compensate */ - yearday += (secs/SECS_PER_DAY)-1; - secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); - } - else { - yearday += (secs/SECS_PER_DAY); - secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); - } + if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { + /* got negative remainder, but need positive time */ + /* back off an extra day to compensate */ + yearday += (secs/SECS_PER_DAY)-1; + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); + } + else { + yearday += (secs/SECS_PER_DAY); + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); + } } else if (secs >= SECS_PER_DAY) { - yearday += (secs/SECS_PER_DAY); - secs %= SECS_PER_DAY; + yearday += (secs/SECS_PER_DAY); + secs %= SECS_PER_DAY; } ptm->tm_hour = secs/SECS_PER_HOUR; secs %= SECS_PER_HOUR; @@ -4124,21 +4124,21 @@ Perl_mini_mktime(struct tm *ptm) year += odd_year; yearday %= DAYS_PER_YEAR; if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ - month = 1; - yearday = 29; + month = 1; + yearday = 29; } else { - yearday += YEAR_ADJUST; /* recover March 1st crock */ - month = yearday*DAYS_TO_MONTH; - yearday -= month*MONTH_TO_DAYS; - /* recover other leap-year adjustment */ - if (month > 13) { - month-=14; - year++; - } - else { - month-=2; - } + yearday += YEAR_ADJUST; /* recover March 1st crock */ + month = yearday*DAYS_TO_MONTH; + yearday -= month*MONTH_TO_DAYS; + /* recover other leap-year adjustment */ + if (month > 13) { + month-=14; + year++; + } + else { + month-=2; + } } ptm->tm_year = year - 1900; if (yearday) { @@ -4247,12 +4247,12 @@ giving localized results. GCC_DIAG_RESTORE_STMT; if (inRANGE(buflen, 1, bufsize - 1)) - break; + break; /* heuristic to prevent out-of-memory errors */ if (bufsize > 100*fmtlen) { - Safefree(buf); - buf = NULL; - break; + Safefree(buf); + buf = NULL; + break; } bufsize *= 2; Renew(buf, bufsize, char); @@ -4272,7 +4272,7 @@ giving localized results. #define SV_CWD_ISDOT(dp) \ (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ - (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) + (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) /* =for apidoc_section $utility @@ -4302,18 +4302,18 @@ Perl_getcwd_sv(pTHX_ SV *sv) #ifdef HAS_GETCWD { - char buf[MAXPATHLEN]; - - /* Some getcwd()s automatically allocate a buffer of the given - * size from the heap if they are given a NULL buffer pointer. - * The problem is that this behaviour is not portable. */ - if (getcwd(buf, sizeof(buf) - 1)) { - sv_setpv(sv, buf); - return TRUE; - } - else { - SV_CWD_RETURN_UNDEF; - } + char buf[MAXPATHLEN]; + + /* Some getcwd()s automatically allocate a buffer of the given + * size from the heap if they are given a NULL buffer pointer. + * The problem is that this behaviour is not portable. */ + if (getcwd(buf, sizeof(buf) - 1)) { + sv_setpv(sv, buf); + return TRUE; + } + else { + SV_CWD_RETURN_UNDEF; + } } #else @@ -4326,7 +4326,7 @@ Perl_getcwd_sv(pTHX_ SV *sv) SvUPGRADE(sv, SVt_PV); if (PerlLIO_lstat(".", &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; + SV_CWD_RETURN_UNDEF; } orig_cdev = statbuf.st_dev; @@ -4335,98 +4335,98 @@ Perl_getcwd_sv(pTHX_ SV *sv) cino = orig_cino; for (;;) { - DIR *dir; - int namelen; - odev = cdev; - oino = cino; - - if (PerlDir_chdir("..") < 0) { - SV_CWD_RETURN_UNDEF; - } - if (PerlLIO_stat(".", &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; - } - - cdev = statbuf.st_dev; - cino = statbuf.st_ino; - - if (odev == cdev && oino == cino) { - break; - } - if (!(dir = PerlDir_open("."))) { - SV_CWD_RETURN_UNDEF; - } - - while ((dp = PerlDir_read(dir)) != NULL) { + DIR *dir; + int namelen; + odev = cdev; + oino = cino; + + if (PerlDir_chdir("..") < 0) { + SV_CWD_RETURN_UNDEF; + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (odev == cdev && oino == cino) { + break; + } + if (!(dir = PerlDir_open("."))) { + SV_CWD_RETURN_UNDEF; + } + + while ((dp = PerlDir_read(dir)) != NULL) { #ifdef DIRNAMLEN - namelen = dp->d_namlen; + namelen = dp->d_namlen; #else - namelen = strlen(dp->d_name); + namelen = strlen(dp->d_name); #endif - /* skip . and .. */ - if (SV_CWD_ISDOT(dp)) { - continue; - } + /* skip . and .. */ + if (SV_CWD_ISDOT(dp)) { + continue; + } - if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; - } + if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } - tdev = statbuf.st_dev; - tino = statbuf.st_ino; - if (tino == oino && tdev == odev) { - break; - } - } + tdev = statbuf.st_dev; + tino = statbuf.st_ino; + if (tino == oino && tdev == odev) { + break; + } + } - if (!dp) { - SV_CWD_RETURN_UNDEF; - } + if (!dp) { + SV_CWD_RETURN_UNDEF; + } - if (pathlen + namelen + 1 >= MAXPATHLEN) { - SV_CWD_RETURN_UNDEF; - } + if (pathlen + namelen + 1 >= MAXPATHLEN) { + SV_CWD_RETURN_UNDEF; + } - SvGROW(sv, pathlen + namelen + 1); + SvGROW(sv, pathlen + namelen + 1); - if (pathlen) { - /* shift down */ - Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char); - } + if (pathlen) { + /* shift down */ + Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char); + } - /* prepend current directory to the front */ - *SvPVX(sv) = '/'; - Move(dp->d_name, SvPVX(sv)+1, namelen, char); - pathlen += (namelen + 1); + /* prepend current directory to the front */ + *SvPVX(sv) = '/'; + Move(dp->d_name, SvPVX(sv)+1, namelen, char); + pathlen += (namelen + 1); #ifdef VOID_CLOSEDIR - PerlDir_close(dir); + PerlDir_close(dir); #else - if (PerlDir_close(dir) < 0) { - SV_CWD_RETURN_UNDEF; - } + if (PerlDir_close(dir) < 0) { + SV_CWD_RETURN_UNDEF; + } #endif } if (pathlen) { - SvCUR_set(sv, pathlen); - *SvEND(sv) = '\0'; - SvPOK_only(sv); + SvCUR_set(sv, pathlen); + *SvEND(sv) = '\0'; + SvPOK_only(sv); - if (PerlDir_chdir(SvPVX_const(sv)) < 0) { - SV_CWD_RETURN_UNDEF; - } + if (PerlDir_chdir(SvPVX_const(sv)) < 0) { + SV_CWD_RETURN_UNDEF; + } } if (PerlLIO_stat(".", &statbuf) < 0) { - SV_CWD_RETURN_UNDEF; + SV_CWD_RETURN_UNDEF; } cdev = statbuf.st_dev; cino = statbuf.st_ino; if (cdev != orig_cdev || cino != orig_cino) { - Perl_croak(aTHX_ "Unstable directory path, " - "current directory changed unexpectedly"); + Perl_croak(aTHX_ "Unstable directory path, " + "current directory changed unexpectedly"); } return TRUE; @@ -4458,31 +4458,31 @@ S_socketpair_udp (int fd[2]) { memset(&addresses, 0, sizeof(addresses)); i = 1; do { - sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET); - if (sockets[i] == -1) - goto tidy_up_and_fail; - - addresses[i].sin_family = AF_INET; - addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK); - addresses[i].sin_port = 0; /* kernel choses port. */ - if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i], - sizeof(struct sockaddr_in)) == -1) - goto tidy_up_and_fail; + sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET); + if (sockets[i] == -1) + goto tidy_up_and_fail; + + addresses[i].sin_family = AF_INET; + addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK); + addresses[i].sin_port = 0; /* kernel choses port. */ + if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i], + sizeof(struct sockaddr_in)) == -1) + goto tidy_up_and_fail; } while (i--); /* Now have 2 UDP sockets. Find out which port each is connected to, and for each connect the other socket to it. */ i = 1; do { - if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i], - &size) == -1) - goto tidy_up_and_fail; - if (size != sizeof(struct sockaddr_in)) - goto abort_tidy_up_and_fail; - /* !1 is 0, !0 is 1 */ - if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], - sizeof(struct sockaddr_in)) == -1) - goto tidy_up_and_fail; + if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i], + &size) == -1) + goto tidy_up_and_fail; + if (size != sizeof(struct sockaddr_in)) + goto abort_tidy_up_and_fail; + /* !1 is 0, !0 is 1 */ + if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i], + sizeof(struct sockaddr_in)) == -1) + goto tidy_up_and_fail; } while (i--); /* Now we have 2 sockets connected to each other. I don't trust some other @@ -4490,16 +4490,16 @@ S_socketpair_udp (int fd[2]) { a packet from each to the other. */ i = 1; do { - /* I'm going to send my own port number. As a short. - (Who knows if someone somewhere has sin_port as a bitfield and needs - this routine. (I'm assuming crays have socketpair)) */ - port = addresses[i].sin_port; - got = PerlLIO_write(sockets[i], &port, sizeof(port)); - if (got != sizeof(port)) { - if (got == -1) - goto tidy_up_and_fail; - goto abort_tidy_up_and_fail; - } + /* I'm going to send my own port number. As a short. + (Who knows if someone somewhere has sin_port as a bitfield and needs + this routine. (I'm assuming crays have socketpair)) */ + port = addresses[i].sin_port; + got = PerlLIO_write(sockets[i], &port, sizeof(port)); + if (got != sizeof(port)) { + if (got == -1) + goto tidy_up_and_fail; + goto abort_tidy_up_and_fail; + } } while (i--); /* Packets sent. I don't trust them to have arrived though. @@ -4513,54 +4513,54 @@ S_socketpair_udp (int fd[2]) { */ { - struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ - int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; - fd_set rset; - - FD_ZERO(&rset); - FD_SET((unsigned int)sockets[0], &rset); - FD_SET((unsigned int)sockets[1], &rset); - - got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor); - if (got != 2 || !FD_ISSET(sockets[0], &rset) - || !FD_ISSET(sockets[1], &rset)) { - /* I hope this is portable and appropriate. */ - if (got == -1) - goto tidy_up_and_fail; - goto abort_tidy_up_and_fail; - } + struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */ + int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0]; + fd_set rset; + + FD_ZERO(&rset); + FD_SET((unsigned int)sockets[0], &rset); + FD_SET((unsigned int)sockets[1], &rset); + + got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor); + if (got != 2 || !FD_ISSET(sockets[0], &rset) + || !FD_ISSET(sockets[1], &rset)) { + /* I hope this is portable and appropriate. */ + if (got == -1) + goto tidy_up_and_fail; + goto abort_tidy_up_and_fail; + } } /* And the paranoia department even now doesn't trust it to have arrive (hence MSG_DONTWAIT). Or that what arrives was sent by us. */ { - struct sockaddr_in readfrom; - unsigned short buffer[2]; + struct sockaddr_in readfrom; + unsigned short buffer[2]; - i = 1; - do { + i = 1; + do { #ifdef MSG_DONTWAIT - got = PerlSock_recvfrom(sockets[i], (char *) &buffer, - sizeof(buffer), MSG_DONTWAIT, - (struct sockaddr *) &readfrom, &size); + got = PerlSock_recvfrom(sockets[i], (char *) &buffer, + sizeof(buffer), MSG_DONTWAIT, + (struct sockaddr *) &readfrom, &size); #else - got = PerlSock_recvfrom(sockets[i], (char *) &buffer, - sizeof(buffer), 0, - (struct sockaddr *) &readfrom, &size); -#endif - - if (got == -1) - goto tidy_up_and_fail; - if (got != sizeof(port) - || size != sizeof(struct sockaddr_in) - /* Check other socket sent us its port. */ - || buffer[0] != (unsigned short) addresses[!i].sin_port - /* Check kernel says we got the datagram from that socket */ - || readfrom.sin_family != addresses[!i].sin_family - || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr - || readfrom.sin_port != addresses[!i].sin_port) - goto abort_tidy_up_and_fail; - } while (i--); + got = PerlSock_recvfrom(sockets[i], (char *) &buffer, + sizeof(buffer), 0, + (struct sockaddr *) &readfrom, &size); +#endif + + if (got == -1) + goto tidy_up_and_fail; + if (got != sizeof(port) + || size != sizeof(struct sockaddr_in) + /* Check other socket sent us its port. */ + || buffer[0] != (unsigned short) addresses[!i].sin_port + /* Check kernel says we got the datagram from that socket */ + || readfrom.sin_family != addresses[!i].sin_family + || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr + || readfrom.sin_port != addresses[!i].sin_port) + goto abort_tidy_up_and_fail; + } while (i--); } /* My caller (my_socketpair) has validated that this is non-NULL */ fd[0] = sockets[0]; @@ -4573,13 +4573,13 @@ S_socketpair_udp (int fd[2]) { errno = ECONNABORTED; tidy_up_and_fail: { - dSAVE_ERRNO; - if (sockets[0] != -1) - PerlLIO_close(sockets[0]); - if (sockets[1] != -1) - PerlLIO_close(sockets[1]); - RESTORE_ERRNO; - return -1; + dSAVE_ERRNO; + if (sockets[0] != -1) + PerlLIO_close(sockets[0]); + if (sockets[1] != -1) + PerlLIO_close(sockets[1]); + RESTORE_ERRNO; + return -1; } } #endif /* EMULATE_SOCKETPAIR_UDP */ @@ -4599,15 +4599,15 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { if (protocol #ifdef AF_UNIX - || family != AF_UNIX + || family != AF_UNIX #endif ) { - errno = EAFNOSUPPORT; - return -1; + errno = EAFNOSUPPORT; + return -1; } if (!fd) { - errno = EINVAL; - return -1; + errno = EINVAL; + return -1; } #ifdef SOCK_CLOEXEC @@ -4616,55 +4616,55 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { #ifdef EMULATE_SOCKETPAIR_UDP if (type == SOCK_DGRAM) - return S_socketpair_udp(fd); + return S_socketpair_udp(fd); #endif aTHXa(PERL_GET_THX); listener = PerlSock_socket(AF_INET, type, 0); if (listener == -1) - return -1; + return -1; memset(&listen_addr, 0, sizeof(listen_addr)); listen_addr.sin_family = AF_INET; listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK); listen_addr.sin_port = 0; /* kernel choses port. */ if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr, - sizeof(listen_addr)) == -1) - goto tidy_up_and_fail; + sizeof(listen_addr)) == -1) + goto tidy_up_and_fail; if (PerlSock_listen(listener, 1) == -1) - goto tidy_up_and_fail; + goto tidy_up_and_fail; connector = PerlSock_socket(AF_INET, type, 0); if (connector == -1) - goto tidy_up_and_fail; + goto tidy_up_and_fail; /* We want to find out the port number to connect to. */ size = sizeof(connect_addr); if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr, - &size) == -1) - goto tidy_up_and_fail; + &size) == -1) + goto tidy_up_and_fail; if (size != sizeof(connect_addr)) - goto abort_tidy_up_and_fail; + goto abort_tidy_up_and_fail; if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr, - sizeof(connect_addr)) == -1) - goto tidy_up_and_fail; + sizeof(connect_addr)) == -1) + goto tidy_up_and_fail; size = sizeof(listen_addr); acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr, - &size); + &size); if (acceptor == -1) - goto tidy_up_and_fail; + goto tidy_up_and_fail; if (size != sizeof(listen_addr)) - goto abort_tidy_up_and_fail; + goto abort_tidy_up_and_fail; PerlLIO_close(listener); /* Now check we are talking to ourself by matching port and host on the two sockets. */ if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr, - &size) == -1) - goto tidy_up_and_fail; + &size) == -1) + goto tidy_up_and_fail; if (size != sizeof(connect_addr) - || listen_addr.sin_family != connect_addr.sin_family - || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr - || listen_addr.sin_port != connect_addr.sin_port) { - goto abort_tidy_up_and_fail; + || listen_addr.sin_family != connect_addr.sin_family + || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr + || listen_addr.sin_port != connect_addr.sin_port) { + goto abort_tidy_up_and_fail; } fd[0] = connector; fd[1] = acceptor; @@ -4680,15 +4680,15 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { #endif tidy_up_and_fail: { - dSAVE_ERRNO; - if (listener != -1) - PerlLIO_close(listener); - if (connector != -1) - PerlLIO_close(connector); - if (acceptor != -1) - PerlLIO_close(acceptor); - RESTORE_ERRNO; - return -1; + dSAVE_ERRNO; + if (listener != -1) + PerlLIO_close(listener); + if (connector != -1) + PerlLIO_close(connector); + if (acceptor != -1) + PerlLIO_close(acceptor); + RESTORE_ERRNO; + return -1; } } #else @@ -4771,37 +4771,37 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) } } else { - for (; *p; p++) { - switch (*p) { - case PERL_UNICODE_STDIN: - opt |= PERL_UNICODE_STDIN_FLAG; break; - case PERL_UNICODE_STDOUT: - opt |= PERL_UNICODE_STDOUT_FLAG; break; - case PERL_UNICODE_STDERR: - opt |= PERL_UNICODE_STDERR_FLAG; break; - case PERL_UNICODE_STD: - opt |= PERL_UNICODE_STD_FLAG; break; - case PERL_UNICODE_IN: - opt |= PERL_UNICODE_IN_FLAG; break; - case PERL_UNICODE_OUT: - opt |= PERL_UNICODE_OUT_FLAG; break; - case PERL_UNICODE_INOUT: - opt |= PERL_UNICODE_INOUT_FLAG; break; - case PERL_UNICODE_LOCALE: - opt |= PERL_UNICODE_LOCALE_FLAG; break; - case PERL_UNICODE_ARGV: - opt |= PERL_UNICODE_ARGV_FLAG; break; - case PERL_UNICODE_UTF8CACHEASSERT: - opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break; - default: - if (*p != '\n' && *p != '\r') { - if(isSPACE(*p)) goto the_end_of_the_opts_parser; - else - Perl_croak(aTHX_ - "Unknown Unicode option letter '%c'", *p); - } - } - } + for (; *p; p++) { + switch (*p) { + case PERL_UNICODE_STDIN: + opt |= PERL_UNICODE_STDIN_FLAG; break; + case PERL_UNICODE_STDOUT: + opt |= PERL_UNICODE_STDOUT_FLAG; break; + case PERL_UNICODE_STDERR: + opt |= PERL_UNICODE_STDERR_FLAG; break; + case PERL_UNICODE_STD: + opt |= PERL_UNICODE_STD_FLAG; break; + case PERL_UNICODE_IN: + opt |= PERL_UNICODE_IN_FLAG; break; + case PERL_UNICODE_OUT: + opt |= PERL_UNICODE_OUT_FLAG; break; + case PERL_UNICODE_INOUT: + opt |= PERL_UNICODE_INOUT_FLAG; break; + case PERL_UNICODE_LOCALE: + opt |= PERL_UNICODE_LOCALE_FLAG; break; + case PERL_UNICODE_ARGV: + opt |= PERL_UNICODE_ARGV_FLAG; break; + case PERL_UNICODE_UTF8CACHEASSERT: + opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break; + default: + if (*p != '\n' && *p != '\r') { + if(isSPACE(*p)) goto the_end_of_the_opts_parser; + else + Perl_croak(aTHX_ + "Unknown Unicode option letter '%c'", *p); + } + } + } } } else @@ -4811,7 +4811,7 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) if (opt & ~PERL_UNICODE_ALL_FLAGS) Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf, - (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); + (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); *popt = p; @@ -4872,11 +4872,11 @@ Perl_seed(pTHX) #endif fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0); if (fd != -1) { - if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u) - u = 0; - PerlLIO_close(fd); - if (u) - return u; + if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u) + u = 0; + PerlLIO_close(fd); + if (u) + return u; } #endif @@ -5019,10 +5019,10 @@ Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer) static void S_mem_log_common(enum mem_log_type mlt, const UV n, - const UV typesize, const char *type_name, const SV *sv, - Malloc_t oldalloc, Malloc_t newalloc, - const char *filename, const int linenumber, - const char *funcname) + const UV typesize, const char *type_name, const SV *sv, + Malloc_t oldalloc, Malloc_t newalloc, + const char *filename, const int linenumber, + const char *funcname) { const char *pmlenv; dTHX; @@ -5033,81 +5033,81 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, pmlenv = PerlEnv_getenv("PERL_MEM_LOG"); PL_mem_log[0] &= ~0x2; if (!pmlenv) - return; + return; if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s')) { - /* We can't use SVs or PerlIO for obvious reasons, - * so we'll use stdio and low-level IO instead. */ - char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; + /* We can't use SVs or PerlIO for obvious reasons, + * so we'll use stdio and low-level IO instead. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; # ifdef HAS_GETTIMEOFDAY # define MEM_LOG_TIME_FMT "%10d.%06d: " # define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec - struct timeval tv; - gettimeofday(&tv, 0); + struct timeval tv; + gettimeofday(&tv, 0); # else # define MEM_LOG_TIME_FMT "%10d: " # define MEM_LOG_TIME_ARG (int)when Time_t when; (void)time(&when); # endif - /* If there are other OS specific ways of hires time than - * gettimeofday() (see dist/Time-HiRes), the easiest way is - * probably that they would be used to fill in the struct - * timeval. */ - { - STRLEN len; + /* If there are other OS specific ways of hires time than + * gettimeofday() (see dist/Time-HiRes), the easiest way is + * probably that they would be used to fill in the struct + * timeval. */ + { + STRLEN len; const char* endptr = pmlenv + strlen(pmlenv); - int fd; + int fd; UV uv; if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */ && uv && uv <= PERL_INT_MAX ) { fd = (int)uv; } else { - fd = PERL_MEM_LOG_FD; + fd = PERL_MEM_LOG_FD; } - if (strchr(pmlenv, 't')) { - len = my_snprintf(buf, sizeof(buf), - MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); - PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len)); - } - switch (mlt) { - case MLT_ALLOC: - len = my_snprintf(buf, sizeof(buf), - "alloc: %s:%d:%s: %" IVdf " %" UVuf - " %s = %" IVdf ": %" UVxf "\n", - filename, linenumber, funcname, n, typesize, - type_name, n * typesize, PTR2UV(newalloc)); - break; - case MLT_REALLOC: - len = my_snprintf(buf, sizeof(buf), - "realloc: %s:%d:%s: %" IVdf " %" UVuf - " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n", - filename, linenumber, funcname, n, typesize, - type_name, n * typesize, PTR2UV(oldalloc), - PTR2UV(newalloc)); - break; - case MLT_FREE: - len = my_snprintf(buf, sizeof(buf), - "free: %s:%d:%s: %" UVxf "\n", - filename, linenumber, funcname, - PTR2UV(oldalloc)); - break; - case MLT_NEW_SV: - case MLT_DEL_SV: - len = my_snprintf(buf, sizeof(buf), - "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n", - mlt == MLT_NEW_SV ? "new" : "del", - filename, linenumber, funcname, - PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv)); - break; - default: - len = 0; - } - PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len)); - } + if (strchr(pmlenv, 't')) { + len = my_snprintf(buf, sizeof(buf), + MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); + PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len)); + } + switch (mlt) { + case MLT_ALLOC: + len = my_snprintf(buf, sizeof(buf), + "alloc: %s:%d:%s: %" IVdf " %" UVuf + " %s = %" IVdf ": %" UVxf "\n", + filename, linenumber, funcname, n, typesize, + type_name, n * typesize, PTR2UV(newalloc)); + break; + case MLT_REALLOC: + len = my_snprintf(buf, sizeof(buf), + "realloc: %s:%d:%s: %" IVdf " %" UVuf + " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n", + filename, linenumber, funcname, n, typesize, + type_name, n * typesize, PTR2UV(oldalloc), + PTR2UV(newalloc)); + break; + case MLT_FREE: + len = my_snprintf(buf, sizeof(buf), + "free: %s:%d:%s: %" UVxf "\n", + filename, linenumber, funcname, + PTR2UV(oldalloc)); + break; + case MLT_NEW_SV: + case MLT_DEL_SV: + len = my_snprintf(buf, sizeof(buf), + "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n", + mlt == MLT_NEW_SV ? "new" : "del", + filename, linenumber, funcname, + PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv)); + break; + default: + len = 0; + } + PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len)); + } } } #endif /* !PERL_MEM_LOG_NOIMPL */ @@ -5127,60 +5127,60 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, Malloc_t Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, - Malloc_t newalloc, - const char *filename, const int linenumber, - const char *funcname) + Malloc_t newalloc, + const char *filename, const int linenumber, + const char *funcname) { PERL_ARGS_ASSERT_MEM_LOG_ALLOC; mem_log_common_if(MLT_ALLOC, n, typesize, type_name, - NULL, NULL, newalloc, - filename, linenumber, funcname); + NULL, NULL, newalloc, + filename, linenumber, funcname); return newalloc; } Malloc_t Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, - Malloc_t oldalloc, Malloc_t newalloc, - const char *filename, const int linenumber, - const char *funcname) + Malloc_t oldalloc, Malloc_t newalloc, + const char *filename, const int linenumber, + const char *funcname) { PERL_ARGS_ASSERT_MEM_LOG_REALLOC; mem_log_common_if(MLT_REALLOC, n, typesize, type_name, - NULL, oldalloc, newalloc, - filename, linenumber, funcname); + NULL, oldalloc, newalloc, + filename, linenumber, funcname); return newalloc; } Malloc_t Perl_mem_log_free(Malloc_t oldalloc, - const char *filename, const int linenumber, - const char *funcname) + const char *filename, const int linenumber, + const char *funcname) { PERL_ARGS_ASSERT_MEM_LOG_FREE; mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, - filename, linenumber, funcname); + filename, linenumber, funcname); return oldalloc; } void Perl_mem_log_new_sv(const SV *sv, - const char *filename, const int linenumber, - const char *funcname) + const char *filename, const int linenumber, + const char *funcname) { mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, - filename, linenumber, funcname); + filename, linenumber, funcname); } void Perl_mem_log_del_sv(const SV *sv, - const char *filename, const int linenumber, - const char *funcname) + const char *filename, const int linenumber, + const char *funcname) { mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, - filename, linenumber, funcname); + filename, linenumber, funcname); } #endif /* PERL_MEM_LOG */ @@ -5355,7 +5355,7 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) (len > 0 && (Size_t)retval >= len) #endif ) - Perl_croak_nocontext("panic: my_snprintf buffer overflow"); + Perl_croak_nocontext("panic: my_snprintf buffer overflow"); return retval; } @@ -5411,7 +5411,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap (len > 0 && (Size_t)retval >= len) #endif ) - Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); + Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); return retval; #endif } @@ -5494,29 +5494,29 @@ Perl_my_cxt_init(pTHX_ int *indexp, size_t size) * other: already allocated by another thread */ if (index == -1) { - MUTEX_LOCK(&PL_my_ctx_mutex); + MUTEX_LOCK(&PL_my_ctx_mutex); /*now a stricter check with locking */ index = *indexp; if (index == -1) /* this module hasn't been allocated an index yet */ *indexp = PL_my_cxt_index++; index = *indexp; - MUTEX_UNLOCK(&PL_my_ctx_mutex); + MUTEX_UNLOCK(&PL_my_ctx_mutex); } /* make sure the array is big enough */ if (PL_my_cxt_size <= index) { - if (PL_my_cxt_size) { + if (PL_my_cxt_size) { IV new_size = PL_my_cxt_size; - while (new_size <= index) - new_size *= 2; - Renew(PL_my_cxt_list, new_size, void *); + while (new_size <= index) + new_size *= 2; + Renew(PL_my_cxt_list, new_size, void *); PL_my_cxt_size = new_size; - } - else { - PL_my_cxt_size = 16; - Newx(PL_my_cxt_list, PL_my_cxt_size, void *); - } + } + else { + PL_my_cxt_size = 16; + Newx(PL_my_cxt_list, PL_my_cxt_size, void *); + } } /* newSV() allocates one more than needed */ p = (void*)SvPVX(newSV(size-1)); @@ -5584,7 +5584,7 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH)); need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH); if (UNLIKELY(got != need)) - goto bad_handshake; + goto bad_handshake; /* try to catch where a 2nd threaded perl interp DLL is loaded into a process by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so @@ -5608,52 +5608,52 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) need = &PL_stack_sp; #endif if(UNLIKELY(got != need)) { - bad_handshake:/* recycle branch and string from above */ - if(got != (void *)HSf_NOCHK) - noperl_die("%s: loadable library and perl binaries are mismatched" + bad_handshake:/* recycle branch and string from above */ + if(got != (void *)HSf_NOCHK) + noperl_die("%s: loadable library and perl binaries are mismatched" " (got handshake key %p, needed %p)\n", - file, got, need); + file, got, need); } if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */ - 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 */ - /* XSUBs can't be perl lang/perl5db.pl debugged - if (PERLDB_LINE_OR_SAVESRC) - (void)gv_fetchfile(file); */ + 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 */ + /* XSUBs can't be perl lang/perl5db.pl debugged + if (PERLDB_LINE_OR_SAVESRC) + (void)gv_fetchfile(file); */ } if(key & HSf_POPMARK) { - ax = POPMARK; - { SV **mark = PL_stack_base + ax++; - { dSP; - items = (I32)(SP - MARK); - } - } + ax = POPMARK; + { SV **mark = PL_stack_base + ax++; + { dSP; + items = (I32)(SP - MARK); + } + } } else { - items = va_arg(args, U32); - ax = va_arg(args, U32); + items = va_arg(args, U32); + ax = va_arg(args, U32); } { - U32 apiverlen; - assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX); - if((apiverlen = HS_GETAPIVERLEN(key))) { - char * api_p = va_arg(args, char*); - if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1 - || memNE(api_p, "v" PERL_API_VERSION_STRING, - sizeof("v" PERL_API_VERSION_STRING)-1)) - Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s", - api_p, SVfARG(PL_stack_base[ax + 0]), - "v" PERL_API_VERSION_STRING); - } + U32 apiverlen; + assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX); + if((apiverlen = HS_GETAPIVERLEN(key))) { + char * api_p = va_arg(args, char*); + if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1 + || memNE(api_p, "v" PERL_API_VERSION_STRING, + sizeof("v" PERL_API_VERSION_STRING)-1)) + Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s", + api_p, SVfARG(PL_stack_base[ax + 0]), + "v" PERL_API_VERSION_STRING); + } } { - U32 xsverlen; - assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX); - if((xsverlen = HS_GETXSVERLEN(key))) - S_xs_version_bootcheck(aTHX_ - items, ax, va_arg(args, char*), xsverlen); + U32 xsverlen; + assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX); + if((xsverlen = HS_GETXSVERLEN(key))) + S_xs_version_bootcheck(aTHX_ + items, ax, va_arg(args, char*), xsverlen); } va_end(args); return ax; @@ -5662,7 +5662,7 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) STATIC void S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, - STRLEN xs_len) + STRLEN xs_len) { SV *sv; const char *vn = NULL; @@ -5671,40 +5671,40 @@ S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK; if (items >= 2) /* version supplied as bootstrap arg */ - sv = PL_stack_base[ax + 1]; + sv = PL_stack_base[ax + 1]; else { - /* XXX GV_ADDWARN */ - vn = "XS_VERSION"; - sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0); - if (!sv || !SvOK(sv)) { - vn = "VERSION"; - sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0); - } + /* XXX GV_ADDWARN */ + vn = "XS_VERSION"; + sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0); + if (!sv || !SvOK(sv)) { + vn = "VERSION"; + sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0); + } } if (sv) { - SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP); - SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version") - ? sv : sv_2mortal(new_version(sv)); - xssv = upg_version(xssv, 0); - if ( vcmp(pmsv,xssv) ) { - SV *string = vstringify(xssv); - SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf - " does not match ", SVfARG(module), SVfARG(string)); - - SvREFCNT_dec(string); - string = vstringify(pmsv); - - if (vn) { - Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn, - SVfARG(string)); - } else { - Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string)); - } - SvREFCNT_dec(string); + SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP); + SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version") + ? sv : sv_2mortal(new_version(sv)); + xssv = upg_version(xssv, 0); + if ( vcmp(pmsv,xssv) ) { + SV *string = vstringify(xssv); + SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf + " does not match ", SVfARG(module), SVfARG(string)); + + SvREFCNT_dec(string); + string = vstringify(pmsv); + + if (vn) { + Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn, + SVfARG(string)); + } else { + Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string)); + } + SvREFCNT_dec(string); - Perl_sv_2mortal(aTHX_ xpt); - Perl_croak_sv(aTHX_ xpt); - } + Perl_sv_2mortal(aTHX_ xpt); + Perl_croak_sv(aTHX_ xpt); + } } } @@ -5793,11 +5793,11 @@ S_gv_has_usable_name(pTHX_ GV *gv) { GV **gvp; return GvSTASH(gv) - && HvENAME(GvSTASH(gv)) - && (gvp = (GV **)hv_fetchhek( - GvSTASH(gv), GvNAME_HEK(gv), 0 - )) - && *gvp == gv; + && HvENAME(GvSTASH(gv)) + && (gvp = (GV **)hv_fetchhek( + GvSTASH(gv), GvNAME_HEK(gv), 0 + )) + && *gvp == gv; } void @@ -5816,40 +5816,40 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) TAINT_set(FALSE); save_item(dbsv); if (!PERLDB_SUB_NN) { - GV *gv = CvGV(cv); - - if (!svp && !CvLEXICAL(cv)) { - gv_efullname3(dbsv, gv, NULL); - } - else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv) - || strEQ(GvNAME(gv), "END") - || ( /* Could be imported, and old sub redefined. */ - (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) - && - !( (SvTYPE(*svp) == SVt_PVGV) - && (GvCV((const GV *)*svp) == cv) - /* Use GV from the stack as a fallback. */ - && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) - ) - ) - ) { - /* GV is potentially non-unique, or contain different CV. */ - SV * const tmp = newRV(MUTABLE_SV(cv)); - sv_setsv(dbsv, tmp); - SvREFCNT_dec(tmp); - } - else { - sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); - sv_catpvs(dbsv, "::"); - sv_cathek(dbsv, GvNAME_HEK(gv)); - } + GV *gv = CvGV(cv); + + if (!svp && !CvLEXICAL(cv)) { + gv_efullname3(dbsv, gv, NULL); + } + else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv) + || strEQ(GvNAME(gv), "END") + || ( /* Could be imported, and old sub redefined. */ + (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) + && + !( (SvTYPE(*svp) == SVt_PVGV) + && (GvCV((const GV *)*svp) == cv) + /* Use GV from the stack as a fallback. */ + && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) + ) + ) + ) { + /* GV is potentially non-unique, or contain different CV. */ + SV * const tmp = newRV(MUTABLE_SV(cv)); + sv_setsv(dbsv, tmp); + SvREFCNT_dec(tmp); + } + else { + sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); + sv_catpvs(dbsv, "::"); + sv_cathek(dbsv, GvNAME_HEK(gv)); + } } else { - const int type = SvTYPE(dbsv); - if (type < SVt_PVIV && type != SVt_IV) - sv_upgrade(dbsv, SVt_PVIV); - (void)SvIOK_on(dbsv); - SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ + const int type = SvTYPE(dbsv); + if (type < SVt_PVIV && type != SVt_IV) + sv_upgrade(dbsv, SVt_PVIV); + (void)SvIOK_on(dbsv); + SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ } SvSETMAGIC(dbsv); TAINT_IF(save_taint); @@ -5945,7 +5945,7 @@ Perl_get_re_arg(pTHX_ SV *sv) { if (SvMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) - sv = MUTABLE_SV(SvRV(sv)); + sv = MUTABLE_SV(SvRV(sv)); if (SvTYPE(sv) == SVt_REGEXP) return (REGEXP*) sv; } @@ -6792,10 +6792,10 @@ Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading) PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD; if (is_loading) { - PERL_LOADING_FILE(name); + PERL_LOADING_FILE(name); } else { - PERL_LOADED_FILE(name); + PERL_LOADED_FILE(name); } } @@ -14,24 +14,24 @@ #ifdef VMS # define PERL_FILE_IS_ABSOLUTE(f) \ - (*(f) == '/' \ - || (strchr(f,':') \ - || ((*(f) == '[' || *(f) == '<') \ - && (isWORDCHAR((f)[1]) || memCHRs("$-_]>",(f)[1]))))) + (*(f) == '/' \ + || (strchr(f,':') \ + || ((*(f) == '[' || *(f) == '<') \ + && (isWORDCHAR((f)[1]) || memCHRs("$-_]>",(f)[1]))))) #elif defined(WIN32) || defined(__CYGWIN__) # define PERL_FILE_IS_ABSOLUTE(f) \ - (*(f) == '/' || *(f) == '\\' /* UNC/rooted path */ \ - || ((f)[0] && (f)[1] == ':')) /* drive name */ + (*(f) == '/' || *(f) == '\\' /* UNC/rooted path */ \ + || ((f)[0] && (f)[1] == ':')) /* drive name */ #elif defined(NETWARE) # define PERL_FILE_IS_ABSOLUTE(f) \ - (((f)[0] && (f)[1] == ':') /* drive name */ \ - || ((f)[0] == '\\' && (f)[1] == '\\') /* UNC path */ \ - || ((f)[3] == ':')) /* volume name, currently only sys */ + (((f)[0] && (f)[1] == ':') /* drive name */ \ + || ((f)[0] == '\\' && (f)[1] == '\\') /* UNC path */ \ + || ((f)[3] == ':')) /* volume name, currently only sys */ #elif defined(DOSISH) # define PERL_FILE_IS_ABSOLUTE(f) \ - (*(f) == '/' \ - || ((f)[0] && (f)[1] == ':')) /* drive name */ + (*(f) == '/' \ + || ((f)[0] && (f)[1] == ':')) /* drive name */ #else /* NOT DOSISH */ # define PERL_FILE_IS_ABSOLUTE(f) (*(f) == '/') #endif @@ -56,7 +56,7 @@ This is a synonym for S<C<(! foldEQ_utf8())>> #define ibcmp(s1, s2, len) cBOOL(! foldEQ(s1, s2, len)) #define ibcmp_locale(s1, s2, len) cBOOL(! foldEQ_locale(s1, s2, len)) #define ibcmp_utf8(s1, pe1, l1, u1, s2, pe2, l2, u2) \ - cBOOL(! foldEQ_utf8(s1, pe1, l1, u1, s2, pe2, l2, u2)) + cBOOL(! foldEQ_utf8(s1, pe1, l1, u1, s2, pe2, l2, u2)) /* outside the core, perl.h undefs HAS_QUAD if IV isn't 64-bit We can't swap this to HAS_QUAD, because the logic here affects the type of diff --git a/vms/munchconfig.c b/vms/munchconfig.c index 8f20417f66..fdd5afde4d 100644 --- a/vms/munchconfig.c +++ b/vms/munchconfig.c @@ -253,7 +253,7 @@ main(int argc, char *argv[]) /* Did we find one? */ if ('$' != LineBuffer[LineBufferLoop]) { /* Nope, spit out the value */ - OutBuf[OutBufPos++] = LineBuffer[LineBufferLoop]; + OutBuf[OutBufPos++] = LineBuffer[LineBufferLoop]; } else { /* Yes, we did. Is it escaped? */ if ((LineBufferLoop > 0) && ('\\' == LineBuffer[LineBufferLoop - @@ -289,8 +289,8 @@ main(int argc, char *argv[]) ConfigSubLoop++) { if (!strcmp(TokenBuffer, ConfigSub[ConfigSubLoop].Tag)) { char *cp = ConfigSub[ConfigSubLoop].Value; - GotIt = 1; - while (*cp) OutBuf[OutBufPos++] = *(cp++); + GotIt = 1; + while (*cp) OutBuf[OutBufPos++] = *(cp++); break; } } @@ -298,9 +298,9 @@ main(int argc, char *argv[]) /* Did we find something? If not, spit out what was in our */ /* buffer */ if (!GotIt) { - char *cp = TokenBuffer; - OutBuf[OutBufPos++] = '$'; - while (*cp) OutBuf[OutBufPos++] = *(cp++); + char *cp = TokenBuffer; + OutBuf[OutBufPos++] = '$'; + while (*cp) OutBuf[OutBufPos++] = *(cp++); } } else { @@ -322,17 +322,17 @@ main(int argc, char *argv[]) LineBufferLoop = 0; OutBuf[OutBufPos] = '\0'; for (i = 0; i <= 1; i++) { - while (!isspace(*cp)) LineBuffer[LineBufferLoop++] = *(cp++); - while ( isspace(*cp)) LineBuffer[LineBufferLoop++] = *(cp++); + while (!isspace(*cp)) LineBuffer[LineBufferLoop++] = *(cp++); + while ( isspace(*cp)) LineBuffer[LineBufferLoop++] = *(cp++); } while (*cp) { - while (isspace(*cp)) LineBuffer[LineBufferLoop++] = *(cp++); - if (!incomment && *cp == '/' && *(cp+1) == '*') incomment = 1; - while (*cp && !isspace(*cp)) { - if (incomment) LineBuffer[LineBufferLoop++] = *cp; - cp++; - } - if (incomment && *cp == '*' && *(cp+1) == '/') incomment = 0; + while (isspace(*cp)) LineBuffer[LineBufferLoop++] = *(cp++); + if (!incomment && *cp == '/' && *(cp+1) == '*') incomment = 1; + while (*cp && !isspace(*cp)) { + if (incomment) LineBuffer[LineBufferLoop++] = *cp; + cp++; + } + if (incomment && *cp == '*' && *(cp+1) == '/') incomment = 0; } LineBuffer[LineBufferLoop] = '\0'; puts(LineBuffer); @@ -62,10 +62,10 @@ #pragma member_alignment save #pragma nomember_alignment longword struct item_list_3 { - unsigned short len; - unsigned short code; - void * bufadr; - unsigned short * retadr; + unsigned short len; + unsigned short code; + void * bufadr; + unsigned short * retadr; }; #pragma member_alignment restore @@ -279,9 +279,9 @@ simple_trnlnm(const char * logname, char * value, int value_len) if ($VMS_STATUS_SUCCESS(status)) { - /* Null terminate and return the string */ - /*--------------------------------------*/ - value[result] = 0; + /* Null terminate and return the string */ + /*--------------------------------------*/ + value[result] = 0; return result; } @@ -305,17 +305,17 @@ is_unix_filespec(const char *path) ret_val = 0; if (! strBEGINs(path,"\"^UP^")) { - pch1 = strchr(path, '/'); - if (pch1 != NULL) - ret_val = 1; - else { - - /* If the user wants UNIX files, "." needs to be treated as in UNIX */ - if (DECC_FILENAME_UNIX_REPORT || DECC_FILENAME_UNIX_ONLY) { - if (strEQ(path,".")) - ret_val = 1; - } - } + pch1 = strchr(path, '/'); + if (pch1 != NULL) + ret_val = 1; + else { + + /* If the user wants UNIX files, "." needs to be treated as in UNIX */ + if (DECC_FILENAME_UNIX_REPORT || DECC_FILENAME_UNIX_ONLY) { + if (strEQ(path,".")) + ret_val = 1; + } + } } return ret_val; } @@ -335,25 +335,25 @@ ucs2_to_vtf7(char *outspec, unsigned long ucs2_char, int * output_cnt) outspec[1] = 'U'; hex = (ucs_ptr[1] >> 4) & 0xf; if (hex < 0xA) - outspec[2] = hex + '0'; + outspec[2] = hex + '0'; else - outspec[2] = (hex - 9) + 'A'; + outspec[2] = (hex - 9) + 'A'; hex = ucs_ptr[1] & 0xF; if (hex < 0xA) - outspec[3] = hex + '0'; + outspec[3] = hex + '0'; else { - outspec[3] = (hex - 9) + 'A'; + outspec[3] = (hex - 9) + 'A'; } hex = (ucs_ptr[0] >> 4) & 0xf; if (hex < 0xA) - outspec[4] = hex + '0'; + outspec[4] = hex + '0'; else - outspec[4] = (hex - 9) + 'A'; + outspec[4] = (hex - 9) + 'A'; hex = ucs_ptr[1] & 0xF; if (hex < 0xA) - outspec[5] = hex + '0'; + outspec[5] = hex + '0'; else { - outspec[5] = (hex - 9) + 'A'; + outspec[5] = (hex - 9) + 'A'; } *output_cnt = 6; } @@ -381,80 +381,80 @@ copy_expand_unix_filename_escape(char *outspec, const char *inspec, int *output_ count = 0; *output_cnt = 0; if (*inspec >= 0x80) { - if (utf8_fl && vms_vtf7_filenames) { - unsigned long ucs_char; - - ucs_char = 0; - - if ((*inspec & 0xE0) == 0xC0) { - /* 2 byte Unicode */ - ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f); - if (ucs_char >= 0x80) { - ucs2_to_vtf7(outspec, ucs_char, output_cnt); - return 2; - } - } else if ((*inspec & 0xF0) == 0xE0) { - /* 3 byte Unicode */ - ucs_char = ((inspec[0] & 0xF) << 12) + - ((inspec[1] & 0x3f) << 6) + - (inspec[2] & 0x3f); - if (ucs_char >= 0x800) { - ucs2_to_vtf7(outspec, ucs_char, output_cnt); - return 3; - } + if (utf8_fl && vms_vtf7_filenames) { + unsigned long ucs_char; + + ucs_char = 0; + + if ((*inspec & 0xE0) == 0xC0) { + /* 2 byte Unicode */ + ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f); + if (ucs_char >= 0x80) { + ucs2_to_vtf7(outspec, ucs_char, output_cnt); + return 2; + } + } else if ((*inspec & 0xF0) == 0xE0) { + /* 3 byte Unicode */ + ucs_char = ((inspec[0] & 0xF) << 12) + + ((inspec[1] & 0x3f) << 6) + + (inspec[2] & 0x3f); + if (ucs_char >= 0x800) { + ucs2_to_vtf7(outspec, ucs_char, output_cnt); + return 3; + } #if 0 /* I do not see longer sequences supported by OpenVMS */ /* Maybe some one can fix this later */ - } else if ((*inspec & 0xF8) == 0xF0) { - /* 4 byte Unicode */ - /* UCS-4 to UCS-2 */ - } else if ((*inspec & 0xFC) == 0xF8) { - /* 5 byte Unicode */ - /* UCS-4 to UCS-2 */ - } else if ((*inspec & 0xFE) == 0xFC) { - /* 6 byte Unicode */ - /* UCS-4 to UCS-2 */ + } else if ((*inspec & 0xF8) == 0xF0) { + /* 4 byte Unicode */ + /* UCS-4 to UCS-2 */ + } else if ((*inspec & 0xFC) == 0xF8) { + /* 5 byte Unicode */ + /* UCS-4 to UCS-2 */ + } else if ((*inspec & 0xFE) == 0xFC) { + /* 6 byte Unicode */ + /* UCS-4 to UCS-2 */ #endif - } - } - - /* High bit set, but not a Unicode character! */ - - /* Non printing DECMCS or ISO Latin-1 character? */ - if ((unsigned char)*inspec <= 0x9F) { - int hex; - outspec[0] = '^'; - outspec++; - hex = (*inspec >> 4) & 0xF; - if (hex < 0xA) - outspec[1] = hex + '0'; - else { - outspec[1] = (hex - 9) + 'A'; - } - hex = *inspec & 0xF; - if (hex < 0xA) - outspec[2] = hex + '0'; - else { - outspec[2] = (hex - 9) + 'A'; - } - *output_cnt = 3; - return 1; - } else if ((unsigned char)*inspec == 0xA0) { - outspec[0] = '^'; - outspec[1] = 'A'; - outspec[2] = '0'; - *output_cnt = 3; - return 1; - } else if ((unsigned char)*inspec == 0xFF) { - outspec[0] = '^'; - outspec[1] = 'F'; - outspec[2] = 'F'; - *output_cnt = 3; - return 1; - } - *outspec = *inspec; - *output_cnt = 1; - return 1; + } + } + + /* High bit set, but not a Unicode character! */ + + /* Non printing DECMCS or ISO Latin-1 character? */ + if ((unsigned char)*inspec <= 0x9F) { + int hex; + outspec[0] = '^'; + outspec++; + hex = (*inspec >> 4) & 0xF; + if (hex < 0xA) + outspec[1] = hex + '0'; + else { + outspec[1] = (hex - 9) + 'A'; + } + hex = *inspec & 0xF; + if (hex < 0xA) + outspec[2] = hex + '0'; + else { + outspec[2] = (hex - 9) + 'A'; + } + *output_cnt = 3; + return 1; + } else if ((unsigned char)*inspec == 0xA0) { + outspec[0] = '^'; + outspec[1] = 'A'; + outspec[2] = '0'; + *output_cnt = 3; + return 1; + } else if ((unsigned char)*inspec == 0xFF) { + outspec[0] = '^'; + outspec[1] = 'F'; + outspec[2] = 'F'; + *output_cnt = 3; + return 1; + } + *outspec = *inspec; + *output_cnt = 1; + return 1; } /* Is this a macro that needs to be passed through? @@ -465,42 +465,42 @@ copy_expand_unix_filename_escape(char *outspec, const char *inspec, int *output_ if ((inspec[0] == '$') && (inspec[1] == '(')) { int tcnt; - if (isALPHA_L1(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) { - tcnt = 3; - outspec[0] = inspec[0]; - outspec[1] = inspec[1]; - outspec[2] = inspec[2]; - - while(isALPHA_L1(inspec[tcnt]) || - (inspec[2] == '.') || (inspec[2] == '_')) { - outspec[tcnt] = inspec[tcnt]; - tcnt++; - } - if (inspec[tcnt] == ')') { - outspec[tcnt] = inspec[tcnt]; - tcnt++; - *output_cnt = tcnt; - return tcnt; - } - } + if (isALPHA_L1(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) { + tcnt = 3; + outspec[0] = inspec[0]; + outspec[1] = inspec[1]; + outspec[2] = inspec[2]; + + while(isALPHA_L1(inspec[tcnt]) || + (inspec[2] == '.') || (inspec[2] == '_')) { + outspec[tcnt] = inspec[tcnt]; + tcnt++; + } + if (inspec[tcnt] == ')') { + outspec[tcnt] = inspec[tcnt]; + tcnt++; + *output_cnt = tcnt; + return tcnt; + } + } } switch (*inspec) { case 0x7f: - outspec[0] = '^'; - outspec[1] = '7'; - outspec[2] = 'F'; - *output_cnt = 3; - return 1; - break; + outspec[0] = '^'; + outspec[1] = '7'; + outspec[2] = 'F'; + *output_cnt = 3; + return 1; + break; case '?': - if (!DECC_EFS_CHARSET) - outspec[0] = '%'; - else - outspec[0] = '?'; - *output_cnt = 1; - return 1; - break; + if (!DECC_EFS_CHARSET) + outspec[0] = '%'; + else + outspec[0] = '?'; + *output_cnt = 1; + return 1; + break; case '.': case '!': case '#': @@ -524,31 +524,31 @@ copy_expand_unix_filename_escape(char *outspec, const char *inspec, int *output_ * already something we escape. */ if (memCHRs(".!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) { - *outspec = *inspec; - *output_cnt = 1; - return 1; - break; + *outspec = *inspec; + *output_cnt = 1; + return 1; + break; } /* But otherwise fall through and escape it. */ case '=': - /* Assume that this is to be escaped */ - outspec[0] = '^'; - outspec[1] = *inspec; - *output_cnt = 2; - return 1; - break; + /* Assume that this is to be escaped */ + outspec[0] = '^'; + outspec[1] = *inspec; + *output_cnt = 2; + return 1; + break; case ' ': /* space */ - /* Assume that this is to be escaped */ - outspec[0] = '^'; - outspec[1] = '_'; - *output_cnt = 2; - return 1; - break; + /* Assume that this is to be escaped */ + outspec[0] = '^'; + outspec[1] = '_'; + *output_cnt = 2; + return 1; + break; default: - *outspec = *inspec; - *output_cnt = 1; - return 1; - break; + *outspec = *inspec; + *output_cnt = 1; + return 1; + break; } return 0; } @@ -572,75 +572,75 @@ copy_expand_vms_filename_escape(char *outspec, const char *inspec, int *output_c count = 0; *output_cnt = 0; if (*inspec == '^') { - inspec++; - switch (*inspec) { + inspec++; + switch (*inspec) { /* Spaces and non-trailing dots should just be passed through, * but eat the escape character. */ - case '.': - *outspec = *inspec; - count += 2; - (*output_cnt)++; - break; - case '_': /* space */ - *outspec = ' '; - count += 2; - (*output_cnt)++; - break; - case '^': + case '.': + *outspec = *inspec; + count += 2; + (*output_cnt)++; + break; + case '_': /* space */ + *outspec = ' '; + count += 2; + (*output_cnt)++; + break; + case '^': /* Hmm. Better leave the escape escaped. */ outspec[0] = '^'; outspec[1] = '^'; - count += 2; - (*output_cnt) += 2; - break; - case 'U': /* Unicode - FIX-ME this is wrong. */ - inspec++; - count++; - scnt = strspn(inspec, "0123456789ABCDEFabcdef"); - if (scnt == 4) { - unsigned int c1, c2; - scnt = sscanf(inspec, "%2x%2x", &c1, &c2); - outspec[0] = c1 & 0xff; - outspec[1] = c2 & 0xff; - if (scnt > 1) { - (*output_cnt) += 2; - count += 4; - } - } - else { - /* Error - do best we can to continue */ - *outspec = 'U'; - outspec++; - (*output_cnt++); - *outspec = *inspec; - count++; - (*output_cnt++); - } - break; - default: - scnt = strspn(inspec, "0123456789ABCDEFabcdef"); - if (scnt == 2) { - /* Hex encoded */ - unsigned int c1; - scnt = sscanf(inspec, "%2x", &c1); - outspec[0] = c1 & 0xff; - if (scnt > 0) { - (*output_cnt++); - count += 2; - } - } - else { - *outspec = *inspec; - count++; - (*output_cnt++); - } - } + count += 2; + (*output_cnt) += 2; + break; + case 'U': /* Unicode - FIX-ME this is wrong. */ + inspec++; + count++; + scnt = strspn(inspec, "0123456789ABCDEFabcdef"); + if (scnt == 4) { + unsigned int c1, c2; + scnt = sscanf(inspec, "%2x%2x", &c1, &c2); + outspec[0] = c1 & 0xff; + outspec[1] = c2 & 0xff; + if (scnt > 1) { + (*output_cnt) += 2; + count += 4; + } + } + else { + /* Error - do best we can to continue */ + *outspec = 'U'; + outspec++; + (*output_cnt++); + *outspec = *inspec; + count++; + (*output_cnt++); + } + break; + default: + scnt = strspn(inspec, "0123456789ABCDEFabcdef"); + if (scnt == 2) { + /* Hex encoded */ + unsigned int c1; + scnt = sscanf(inspec, "%2x", &c1); + outspec[0] = c1 & 0xff; + if (scnt > 0) { + (*output_cnt++); + count += 2; + } + } + else { + *outspec = *inspec; + count++; + (*output_cnt++); + } + } } else { - *outspec = *inspec; - count++; - (*output_cnt)++; + *outspec = *inspec; + count++; + (*output_cnt)++; } return count; } @@ -740,24 +740,24 @@ vms_split_path(const char * path, char * * volume, int * vol_len, char * * root, status = sys$filescan ((const struct dsc$descriptor_s *)&path_desc, item_list, - &flags, NULL, NULL); + &flags, NULL, NULL); _ckvmssts_noperl(status); /* All failure status values indicate a coding error */ /* If we parsed it successfully these two lengths should be the same */ if (path_desc.dsc$w_length != item_list[filespec].length) - return ret_stat; + return ret_stat; /* If we got here, then it is a VMS file specification */ ret_stat = 0; /* set the volume name */ if (item_list[nodespec].length > 0) { - *volume = item_list[nodespec].component; - *vol_len = item_list[nodespec].length + item_list[devspec].length; + *volume = item_list[nodespec].component; + *vol_len = item_list[nodespec].length + item_list[devspec].length; } else { - *volume = item_list[devspec].component; - *vol_len = item_list[devspec].length; + *volume = item_list[devspec].component; + *vol_len = item_list[devspec].length; } *root = item_list[rootspec].component; @@ -771,22 +771,22 @@ vms_split_path(const char * path, char * * volume, int * vol_len, char * * root, * delimiter or a part of the file specification. */ if ((DECC_EFS_CHARSET) && - (item_list[verspec].length > 0) && - (item_list[verspec].component[0] == '.')) { - *name = item_list[namespec].component; - *name_len = item_list[namespec].length + item_list[typespec].length; - *ext = item_list[verspec].component; - *ext_len = item_list[verspec].length; - *version = NULL; - *ver_len = 0; + (item_list[verspec].length > 0) && + (item_list[verspec].component[0] == '.')) { + *name = item_list[namespec].component; + *name_len = item_list[namespec].length + item_list[typespec].length; + *ext = item_list[verspec].component; + *ext_len = item_list[verspec].length; + *version = NULL; + *ver_len = 0; } else { - *name = item_list[namespec].component; - *name_len = item_list[namespec].length; - *ext = item_list[typespec].component; - *ext_len = item_list[typespec].length; - *version = item_list[verspec].component; - *ver_len = item_list[verspec].length; + *name = item_list[namespec].component; + *name_len = item_list[namespec].length; + *ext = item_list[typespec].component; + *ext_len = item_list[typespec].length; + *version = item_list[verspec].component; + *ver_len = item_list[verspec].length; } return ret_stat; } @@ -964,19 +964,19 @@ Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, if (eqvlen > MAX_DCL_SYMBOL) { set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU); eqvlen = MAX_DCL_SYMBOL; - /* Special hack--we might be called before the interpreter's */ - /* fully initialized, in which case either thr or PL_curcop */ - /* might be bogus. We have to check, since ckWARN needs them */ - /* both to be valid if running threaded */ + /* Special hack--we might be called before the interpreter's */ + /* fully initialized, in which case either thr or PL_curcop */ + /* might be bogus. We have to check, since ckWARN needs them */ + /* both to be valid if running threaded */ #if defined(PERL_IMPLICIT_CONTEXT) if (aTHX == NULL) { fprintf(stderr, "Value of CLI symbol \"%s\" too long",lnm); } else #endif - if (ckWARN(WARN_MISC)) { - Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm); - } + if (ckWARN(WARN_MISC)) { + Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm); + } } strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen); } @@ -1106,14 +1106,14 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) /* Get rid of "000000/ in rooted filespecs */ if (len > 7) { char * zeros; - zeros = strstr(eqv, "/000000/"); - if (zeros != NULL) { - int mlen; - mlen = len - (zeros - eqv) - 7; - memmove(zeros, &zeros[7], mlen); - len = len - 7; - eqv[len] = '\0'; - } + zeros = strstr(eqv, "/000000/"); + if (zeros != NULL) { + int mlen; + mlen = len - (zeros - eqv) - 7; + memmove(zeros, &zeros[7], mlen); + len = len - 7; + eqv[len] = '\0'; + } } return eqv; } @@ -1203,12 +1203,12 @@ Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys) if (*len > 7) { zeros = strstr(buf, "/000000/"); if (zeros != NULL) { - int mlen; - mlen = *len - (zeros - buf) - 7; - memmove(zeros, &zeros[7], mlen); - *len = *len - 7; - buf[*len] = '\0'; - } + int mlen; + mlen = *len - (zeros - buf) - 7; + memmove(zeros, &zeros[7], mlen); + *len = *len - 7; + buf[*len] = '\0'; + } } return buf; } @@ -1242,15 +1242,15 @@ Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys) /* Get rid of "000000/ in rooted filespecs */ if (*len > 7) { - char * zeros; - zeros = strstr(buf, "/000000/"); - if (zeros != NULL) { - int mlen; - mlen = *len - (zeros - buf) - 7; - memmove(zeros, &zeros[7], mlen); - *len = *len - 7; - buf[*len] = '\0'; - } + char * zeros; + zeros = strstr(buf, "/000000/"); + if (zeros != NULL) { + int mlen; + mlen = *len - (zeros - buf) - 7; + memmove(zeros, &zeros[7], mlen); + *len = *len - 7; + buf[*len] = '\0'; + } } return *len ? buf : NULL; @@ -1572,22 +1572,22 @@ Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s * } else { if (!*eqv) eqvdsc.dsc$w_length = 1; - if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) { + if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) { nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH; if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) { - Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes", + Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes", lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1)); eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1); nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1; - } + } Newx(ilist,nseg+1,struct itmlst_3); ile = ilist; if (!ile) { - set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM); + set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM); return SS$_INSFMEM; - } + } memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1))); for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) { @@ -1605,10 +1605,10 @@ Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s * retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist); Safefree (ilist); - } + } else { retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0); - } + } } } } @@ -1810,7 +1810,7 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK); if (rslt == NULL) { PerlMem_free(vmsname); - return -1; + return -1; } /* Erase the file */ @@ -1818,8 +1818,8 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) /* Did it succeed */ if ($VMS_STATUS_SUCCESS(rmsts)) { - PerlMem_free(vmsname); - return 0; + PerlMem_free(vmsname); + return 0; } /* If not, can changing protections help? */ @@ -1868,10 +1868,10 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) rmsts = rms_erase(vmsname); if ($VMS_STATUS_SUCCESS(rmsts)) { - rmsts = 0; - } - else { - rmsts = -1; + rmsts = 0; + } + else { + rmsts = -1; /* We blew it - dir with files in it, no write priv for * parent directory, etc. Put things back the way they were. */ if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1)) @@ -1937,8 +1937,8 @@ Perl_do_rmdir(pTHX_ const char *name) } if (!S_ISDIR(st.st_mode)) { - errno = ENOTDIR; - retval = -1; + errno = ENOTDIR; + retval = -1; } else { dirfile = st.st_devnam; @@ -1951,7 +1951,7 @@ Perl_do_rmdir(pTHX_ const char *name) return -1; } - retval = mp_do_kill_file(aTHX_ dirfile, 1); + retval = mp_do_kill_file(aTHX_ dirfile, 1); } return retval; @@ -2186,8 +2186,8 @@ Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act, struct sigaction* oact) { if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) { - SETERRNO(EINVAL, SS$_INVARG); - return -1; + SETERRNO(EINVAL, SS$_INVARG); + return -1; } return sigaction(sig, act, oact); } @@ -2284,7 +2284,7 @@ Perl_sig_to_vmscondition(int sig) { #ifdef SS$_DEBUG if (vms_debug_on_exception != 0) - lib$signal(SS$_DEBUG); + lib$signal(SS$_DEBUG); #endif return Perl_sig_to_vmscondition_int(sig); } @@ -2311,32 +2311,32 @@ Perl_my_kill(int pid, int sig) /* sig 0 means validate the PID */ /*------------------------------*/ if (sig == 0) { - const unsigned long int jpicode = JPI$_PID; - pid_t ret_pid; - int status; + const unsigned long int jpicode = JPI$_PID; + pid_t ret_pid; + int status; status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL); - if ($VMS_STATUS_SUCCESS(status)) - return 0; - switch (status) { + if ($VMS_STATUS_SUCCESS(status)) + return 0; + switch (status) { case SS$_NOSUCHNODE: case SS$_UNREACHABLE: - case SS$_NONEXPR: - errno = ESRCH; - break; - case SS$_NOPRIV: - errno = EPERM; - break; - default: - errno = EVMSERR; - } - vaxc$errno=status; - return -1; + case SS$_NONEXPR: + errno = ESRCH; + break; + case SS$_NOPRIV: + errno = EPERM; + break; + default: + errno = EVMSERR; + } + vaxc$errno=status; + return -1; } code = Perl_sig_to_vmscondition_int(sig); if (!code) { - SETERRNO(EINVAL, SS$_BADPARAM); + SETERRNO(EINVAL, SS$_BADPARAM); return -1; } @@ -2351,7 +2351,7 @@ Perl_my_kill(int pid, int sig) */ if (pid <= 0) { - return killpg(-pid, sig); + return killpg(-pid, sig); } iss = sys$sigprc((unsigned int *)&pid,0,code); @@ -2572,17 +2572,17 @@ Perl_vms_status_to_unix(int vms_status, int child_flag) if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) { switch(msg_no) { case SS$_NORMAL: - unix_status = 0; - break; + unix_status = 0; + break; case SS$_ACCVIO: - unix_status = EFAULT; - break; + unix_status = EFAULT; + break; case SS$_DEVOFFLINE: - unix_status = EBUSY; - break; + unix_status = EBUSY; + break; case SS$_CLEARED: - unix_status = ENOTCONN; - break; + unix_status = ENOTCONN; + break; case SS$_IVCHAN: case SS$_IVLOGNAM: case SS$_BADPARAM: @@ -2593,133 +2593,133 @@ Perl_vms_status_to_unix(int vms_status, int child_flag) case SS$_INVARG: case SS$_NOSUCHID: case SS$_IVIDENT: - unix_status = EINVAL; - break; + unix_status = EINVAL; + break; case SS$_UNSUPPORTED: - unix_status = ENOTSUP; - break; + unix_status = ENOTSUP; + break; case SS$_FILACCERR: case SS$_NOGRPPRV: case SS$_NOSYSPRV: - unix_status = EACCES; - break; + unix_status = EACCES; + break; case SS$_DEVICEFULL: - unix_status = ENOSPC; - break; + unix_status = ENOSPC; + break; case SS$_NOSUCHDEV: - unix_status = ENODEV; - break; + unix_status = ENODEV; + break; case SS$_NOSUCHFILE: case SS$_NOSUCHOBJECT: - unix_status = ENOENT; - break; + unix_status = ENOENT; + break; case SS$_ABORT: /* Fatal case */ case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */ case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */ - unix_status = EINTR; - break; + unix_status = EINTR; + break; case SS$_BUFFEROVF: - unix_status = E2BIG; - break; + unix_status = E2BIG; + break; case SS$_INSFMEM: - unix_status = ENOMEM; - break; + unix_status = ENOMEM; + break; case SS$_NOPRIV: - unix_status = EPERM; - break; + unix_status = EPERM; + break; case SS$_NOSUCHNODE: case SS$_UNREACHABLE: - unix_status = ESRCH; - break; + unix_status = ESRCH; + break; case SS$_NONEXPR: - unix_status = ECHILD; - break; + unix_status = ECHILD; + break; default: - if ((facility == 0) && (msg_no < 8)) { - /* These are not real VMS status codes so assume that they are + if ((facility == 0) && (msg_no < 8)) { + /* These are not real VMS status codes so assume that they are ** already UNIX status codes - */ - unix_status = msg_no; - break; - } + */ + unix_status = msg_no; + break; + } } } else { /* Translate a POSIX exit code to a UNIX exit code */ if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) { - unix_status = (msg_no & 0x07F8) >> 3; + unix_status = (msg_no & 0x07F8) >> 3; } else { - /* Documented traditional behavior for handling VMS child exits */ - /*--------------------------------------------------------------*/ - if (child_flag != 0) { - - /* Success / Informational return 0 */ - /*----------------------------------*/ - if (msg_no & STS$K_SUCCESS) - return 0; - - /* Warning returns 1 */ - /*-------------------*/ - if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0) - return 1; - - /* Everything else pass through the severity bits */ - /*------------------------------------------------*/ - return (msg_no & STS$M_SEVERITY); - } - - /* Normal VMS status to ERRNO mapping attempt */ - /*--------------------------------------------*/ - switch(msg_status) { - /* case RMS$_EOF: */ /* End of File */ - case RMS$_FNF: /* File Not Found */ - case RMS$_DNF: /* Dir Not Found */ - unix_status = ENOENT; - break; - case RMS$_RNF: /* Record Not Found */ - unix_status = ESRCH; - break; - case RMS$_DIR: - unix_status = ENOTDIR; - break; - case RMS$_DEV: - unix_status = ENODEV; - break; - case RMS$_IFI: - case RMS$_FAC: - case RMS$_ISI: - unix_status = EBADF; - break; - case RMS$_FEX: - unix_status = EEXIST; - break; - case RMS$_SYN: - case RMS$_FNM: - case LIB$_INVSTRDES: - case LIB$_INVARG: - case LIB$_NOSUCHSYM: - case LIB$_INVSYMNAM: - case DCL_IVVERB: - unix_status = EINVAL; - break; - case CLI$_BUFOVF: - case RMS$_RTB: - case CLI$_TKNOVF: - case CLI$_RSLOVF: - unix_status = E2BIG; - break; - case RMS$_PRV: /* No privilege */ - case RMS$_ACC: /* ACP file access failed */ - case RMS$_WLK: /* Device write locked */ - unix_status = EACCES; - break; - case RMS$_MKD: /* Failed to mark for delete */ - unix_status = EPERM; - break; - /* case RMS$_NMF: */ /* No more files */ - } + /* Documented traditional behavior for handling VMS child exits */ + /*--------------------------------------------------------------*/ + if (child_flag != 0) { + + /* Success / Informational return 0 */ + /*----------------------------------*/ + if (msg_no & STS$K_SUCCESS) + return 0; + + /* Warning returns 1 */ + /*-------------------*/ + if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0) + return 1; + + /* Everything else pass through the severity bits */ + /*------------------------------------------------*/ + return (msg_no & STS$M_SEVERITY); + } + + /* Normal VMS status to ERRNO mapping attempt */ + /*--------------------------------------------*/ + switch(msg_status) { + /* case RMS$_EOF: */ /* End of File */ + case RMS$_FNF: /* File Not Found */ + case RMS$_DNF: /* Dir Not Found */ + unix_status = ENOENT; + break; + case RMS$_RNF: /* Record Not Found */ + unix_status = ESRCH; + break; + case RMS$_DIR: + unix_status = ENOTDIR; + break; + case RMS$_DEV: + unix_status = ENODEV; + break; + case RMS$_IFI: + case RMS$_FAC: + case RMS$_ISI: + unix_status = EBADF; + break; + case RMS$_FEX: + unix_status = EEXIST; + break; + case RMS$_SYN: + case RMS$_FNM: + case LIB$_INVSTRDES: + case LIB$_INVARG: + case LIB$_NOSUCHSYM: + case LIB$_INVSYMNAM: + case DCL_IVVERB: + unix_status = EINVAL; + break; + case CLI$_BUFOVF: + case RMS$_RTB: + case CLI$_TKNOVF: + case CLI$_RSLOVF: + unix_status = E2BIG; + break; + case RMS$_PRV: /* No privilege */ + case RMS$_ACC: /* ACP file access failed */ + case RMS$_WLK: /* Device write locked */ + unix_status = EACCES; + break; + case RMS$_MKD: /* Failed to mark for delete */ + unix_status = EPERM; + break; + /* case RMS$_NMF: */ /* No more files */ + } } } @@ -2739,23 +2739,23 @@ Perl_unix_status_to_vms(int unix_status) /* Trivial cases first */ /*---------------------*/ if (unix_status == EVMSERR) - return vaxc$errno; + return vaxc$errno; /* Is vaxc$errno sane? */ /*---------------------*/ test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0); if (test_unix_status == unix_status) - return vaxc$errno; + return vaxc$errno; /* If way out of range, must be VMS code already */ /*-----------------------------------------------*/ if (unix_status > EVMSERR) - return unix_status; + return unix_status; /* If out of range, punt */ /*-----------------------*/ if (unix_status > __ERRNO_MAX) - return SS$_ABORT; + return SS$_ABORT; /* Ok, now we have to do it the hard way. */ @@ -2843,7 +2843,7 @@ Perl_unix_status_to_vms(int unix_status) /* case EFAIL */ /* case EINPROG */ case ENOTSUP: - return SS$_UNSUPPORTED; + return SS$_UNSUPPORTED; /* case EDEADLK */ /* case ENWAIT */ /* case EILSEQ */ @@ -2851,7 +2851,7 @@ Perl_unix_status_to_vms(int unix_status) /* case EBADMSG */ /* case EABANDONED */ default: - return SS$_ABORT; /* punt */ + return SS$_ABORT; /* punt */ } } @@ -3542,43 +3542,43 @@ pipe_mbxtofd_setup(pTHX_ int fd, char *out) /* things like terminals and mbx's don't need this filter */ if (fd && fstat(fd,&s) == 0) { unsigned long devchar; - char device[65]; - unsigned short dev_len; - struct dsc$descriptor_s d_dev; - char * cptr; - struct item_list_3 items[3]; - int status; - unsigned short dvi_iosb[4]; - - cptr = getname(fd, out, 1); - if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV); - d_dev.dsc$a_pointer = out; - d_dev.dsc$w_length = strlen(out); - d_dev.dsc$b_dtype = DSC$K_DTYPE_T; - d_dev.dsc$b_class = DSC$K_CLASS_S; - - items[0].len = 4; - items[0].code = DVI$_DEVCHAR; - items[0].bufadr = &devchar; - items[0].retadr = NULL; - items[1].len = 64; - items[1].code = DVI$_FULLDEVNAM; - items[1].bufadr = device; - items[1].retadr = &dev_len; - items[2].len = 0; - items[2].code = 0; - - status = sys$getdviw - (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL); - _ckvmssts_noperl(status); - if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) { - device[dev_len] = 0; - - if (!(devchar & DEV$M_DIR)) { - strcpy(out, device); - return 0; - } - } + char device[65]; + unsigned short dev_len; + struct dsc$descriptor_s d_dev; + char * cptr; + struct item_list_3 items[3]; + int status; + unsigned short dvi_iosb[4]; + + cptr = getname(fd, out, 1); + if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV); + d_dev.dsc$a_pointer = out; + d_dev.dsc$w_length = strlen(out); + d_dev.dsc$b_dtype = DSC$K_DTYPE_T; + d_dev.dsc$b_class = DSC$K_CLASS_S; + + items[0].len = 4; + items[0].code = DVI$_DEVCHAR; + items[0].bufadr = &devchar; + items[0].retadr = NULL; + items[1].len = 64; + items[1].code = DVI$_FULLDEVNAM; + items[1].bufadr = device; + items[1].retadr = &dev_len; + items[2].len = 0; + items[2].code = 0; + + status = sys$getdviw + (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL); + _ckvmssts_noperl(status); + if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) { + device[dev_len] = 0; + + if (!(devchar & DEV$M_DIR)) { + strcpy(out, device); + return 0; + } + } } _ckvmssts_noperl(lib$get_vm(&n, &p)); @@ -3703,28 +3703,28 @@ store_pipelocs(pTHX) #endif my_strlcpy(temp, PL_origargv[0], sizeof(temp)); x = strrchr(temp,']'); - if (x == NULL) { - x = strrchr(temp,'>'); - if (x == NULL) { - /* It could be a UNIX path */ - x = strrchr(temp,'/'); - } - } - if (x) - x[1] = '\0'; - else { - /* Got a bare name, so use default directory */ - temp[0] = '.'; - temp[1] = '\0'; - } + if (x == NULL) { + x = strrchr(temp,'>'); + if (x == NULL) { + /* It could be a UNIX path */ + x = strrchr(temp,'/'); + } + } + if (x) + x[1] = '\0'; + else { + /* Got a bare name, so use default directory */ + temp[0] = '.'; + temp[1] = '\0'; + } if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) { p = (pPLOC) PerlMem_malloc(sizeof(PLOC)); - if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM); + if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM); p->next = head_PLOC; head_PLOC = p; my_strlcpy(p->dir, unixdir, sizeof(p->dir)); - } + } } /* reverse order of @INC entries, skip "." since entered above */ @@ -3754,7 +3754,7 @@ store_pipelocs(pTHX) #ifdef ARCHLIB_EXP if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) { p = (pPLOC) PerlMem_malloc(sizeof(PLOC)); - if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM); + if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM); p->next = head_PLOC; head_PLOC = p; my_strlcpy(p->dir, unixdir, sizeof(p->dir)); @@ -3782,7 +3782,7 @@ find_vmspipe(pTHX) if (vmspipe_file_status == 1) { if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN) && cando_by_name_int - (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) { + (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) { return vmspipe_file; } vmspipe_file_status = 0; @@ -3795,9 +3795,9 @@ find_vmspipe(pTHX) pPLOC p = head_PLOC; while (p) { - char * exp_res; - int dirlen; - dirlen = my_strlcpy(file, p->dir, sizeof(file)); + char * exp_res; + int dirlen; + dirlen = my_strlcpy(file, p->dir, sizeof(file)); my_strlcat(file, "vmspipe.com", sizeof(file)); p = p->next; @@ -3805,9 +3805,9 @@ find_vmspipe(pTHX) if (!exp_res) continue; if (cando_by_name_int - (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN) + (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN) && cando_by_name_int - (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) { + (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) { vmspipe_file_status = 1; return vmspipe_file; } @@ -3849,19 +3849,19 @@ vmspipe_tempfile(pTHX) if (!fp) { sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index); fp = fopen(file,"w"); - } + } } } else { sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index); fp = fopen(file,"w"); if (!fp) { - sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index); - fp = fopen(file,"w"); - if (!fp) { - sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index); - fp = fopen(file,"w"); - } + sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index); + fp = fopen(file,"w"); + if (!fp) { + sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index); + fp = fopen(file,"w"); + } } } if (!fp) return 0; /* we're hosed */ @@ -3896,7 +3896,7 @@ vmspipe_tempfile(pTHX) fclose(fp); if (DECC_FILENAME_UNIX_ONLY) - int_tounixspec(file, file, NULL); + int_tounixspec(file, file, NULL); fp = fopen(file,"r","shr=get"); if (!fp) return 0; fstat(fileno(fp), &s1.crtl_stat); @@ -3936,7 +3936,7 @@ vms_is_syscommand_xterm(void) items[1].code = 0; status = sys$getdviw - (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL); + (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL); if ($VMS_STATUS_SUCCESS(status)) { status = dvi_iosb[0]; @@ -3944,7 +3944,7 @@ vms_is_syscommand_xterm(void) if (!$VMS_STATUS_SUCCESS(status)) { SETERRNO(EVMSERR, status); - return -1; + return -1; } /* If it does, then for now assume that we are on a workstation */ @@ -3959,7 +3959,7 @@ vms_is_syscommand_xterm(void) items[1].code = 0; status = sys$getdviw - (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL); + (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL); if ($VMS_STATUS_SUCCESS(status)) { status = dvi_iosb[0]; @@ -3967,12 +3967,12 @@ vms_is_syscommand_xterm(void) if (!$VMS_STATUS_SUCCESS(status)) { SETERRNO(EVMSERR, status); - return -1; + return -1; } else { - if (devclass == DC$_TERM) { - return 0; - } + if (devclass == DC$_TERM) { + return 0; + } } return -1; } @@ -4009,75 +4009,75 @@ create_forked_xterm(pTHX_ const char *cmd, const char *mode) /* Make sure that this is from the Perl debugger */ ret_char = strstr(cmd," xterm "); if (ret_char == NULL) - return NULL; + return NULL; cptr = ret_char + 7; ret_char = strstr(cmd,"tty"); if (ret_char == NULL) - return NULL; + return NULL; ret_char = strstr(cmd,"sleep"); if (ret_char == NULL) - return NULL; + return NULL; if (decw_term_port == 0) { - $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12"); - $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR"); - $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT"); + $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12"); + $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR"); + $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT"); status = lib$find_image_symbol - (&filename1_dsc, - &decw_term_port_dsc, - (void *)&decw_term_port, - NULL, - 0); + (&filename1_dsc, + &decw_term_port_dsc, + (void *)&decw_term_port, + NULL, + 0); - /* Try again with the other image name */ - if (!$VMS_STATUS_SUCCESS(status)) { + /* Try again with the other image name */ + if (!$VMS_STATUS_SUCCESS(status)) { status = lib$find_image_symbol - (&filename2_dsc, - &decw_term_port_dsc, - (void *)&decw_term_port, - NULL, - 0); + (&filename2_dsc, + &decw_term_port_dsc, + (void *)&decw_term_port, + NULL, + 0); - } + } } /* No decw$term_port, give it up */ if (!$VMS_STATUS_SUCCESS(status)) - return NULL; + return NULL; /* Are we on a workstation? */ /* to do: capture the rows / columns and pass their properties */ ret_stat = vms_is_syscommand_xterm(); if (ret_stat < 0) - return NULL; + return NULL; /* Make the title: */ ret_char = strstr(cptr,"-title"); if (ret_char != NULL) { - while ((*cptr != 0) && (*cptr != '\"')) { - cptr++; - } - if (*cptr == '\"') - cptr++; - n = 0; - while ((*cptr != 0) && (*cptr != '\"')) { - title[n] = *cptr; - n++; - if (n == 39) { - title[39] = 0; - break; - } - cptr++; - } - title[n] = 0; + while ((*cptr != 0) && (*cptr != '\"')) { + cptr++; + } + if (*cptr == '\"') + cptr++; + n = 0; + while ((*cptr != 0) && (*cptr != '\"')) { + title[n] = *cptr; + n++; + if (n == 39) { + title[39] = 0; + break; + } + cptr++; + } + title[n] = 0; } else { - /* Default title */ - strcpy(title,"Perl Debug DECTerm"); + /* Default title */ + strcpy(title,"Perl Debug DECTerm"); } sprintf(customization, cust_str, title); @@ -4096,16 +4096,16 @@ create_forked_xterm(pTHX_ const char *cmd, const char *mode) /* Try to create the window */ status = (*decw_term_port) (NULL, - NULL, - &customization_dsc, - &device_name_dsc, - &device_name_len, - NULL, - NULL, - NULL); + NULL, + &customization_dsc, + &device_name_dsc, + &device_name_len, + NULL, + NULL, + NULL); if (!$VMS_STATUS_SUCCESS(status)) { SETERRNO(EVMSERR, status); - return NULL; + return NULL; } device_name[device_name_len] = '\0'; @@ -4141,7 +4141,7 @@ create_forked_xterm(pTHX_ const char *cmd, const char *mode) status = sys$assign(&device_name_dsc,&info->xchan,0,0); if (!$VMS_STATUS_SUCCESS(status)) { SETERRNO(EVMSERR, status); - return NULL; + return NULL; } info->xchan_valid = 1; @@ -4155,7 +4155,7 @@ create_forked_xterm(pTHX_ const char *cmd, const char *mode) if (!$VMS_STATUS_SUCCESS(status)) { SETERRNO(EVMSERR, status); - return NULL; + return NULL; } info->fp = PerlIO_open(mbx1, mode); @@ -4165,9 +4165,9 @@ create_forked_xterm(pTHX_ const char *cmd, const char *mode) /* If any errors, then clean up */ if (!info->fp) { - n = sizeof(Info); - _ckvmssts_noperl(lib$free_vm(&n, &info)); - return NULL; + n = sizeof(Info); + _ckvmssts_noperl(lib$free_vm(&n, &info)); + return NULL; } /* All done */ @@ -4218,9 +4218,9 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) xterm_fd = NULL; if (aTHX != NULL) #endif - xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode); - if (xterm_fd != NULL) - return xterm_fd; + xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode); + if (xterm_fd != NULL) + return xterm_fd; } if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */ @@ -4344,7 +4344,7 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) info->out->info = info; } if (!info->useFILE) { - info->fp = PerlIO_open(mbx, mode); + info->fp = PerlIO_open(mbx, mode); } else { info->fp = (PerlIO *) freopen(mbx, mode, stdin); vmssetuserlnm("SYS$INPUT", mbx); @@ -4399,7 +4399,7 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) info->in = pipe_tochild_setup(aTHX_ in,mbx); if (!info->useFILE) { - info->fp = PerlIO_open(mbx, mode); + info->fp = PerlIO_open(mbx, mode); } else { info->fp = (PerlIO *) freopen(mbx, mode, stdout); vmssetuserlnm("SYS$OUTPUT", mbx); @@ -4906,21 +4906,21 @@ rms_free_search_context(struct FAB * fab) #define rms_nam_rsl(nam) nam.nam$b_rsl #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam #define rms_set_fna(fab, nam, name, size) \ - { fab.fab$b_fns = size; fab.fab$l_fna = name; } + { fab.fab$b_fns = size; fab.fab$l_fna = name; } #define rms_get_fna(fab, nam) fab.fab$l_fna #define rms_set_dna(fab, nam, name, size) \ - { fab.fab$b_dns = size; fab.fab$l_dna = name; } + { fab.fab$b_dns = size; fab.fab$l_dna = name; } #define rms_nam_dns(fab, nam) fab.fab$b_dns #define rms_set_esa(nam, name, size) \ - { nam.nam$b_ess = size; nam.nam$l_esa = name; } + { nam.nam$b_ess = size; nam.nam$l_esa = name; } #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \ - { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;} + { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;} #define rms_set_rsa(nam, name, size) \ - { nam.nam$l_rsa = name; nam.nam$b_rss = size; } + { nam.nam$l_rsa = name; nam.nam$b_rss = size; } #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \ - { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; } + { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; } #define rms_nam_name_type_l_size(nam) \ - (nam.nam$b_name + nam.nam$b_type) + (nam.nam$b_name + nam.nam$b_type) #else static int rms_free_search_context(struct FAB * fab) @@ -4953,33 +4953,33 @@ rms_free_search_context(struct FAB * fab) #define rms_nam_rsl(nam) nam.naml$b_rsl #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam #define rms_set_fna(fab, nam, name, size) \ - { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \ - nam.naml$l_long_filename_size = size; \ - nam.naml$l_long_filename = name;} + { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \ + nam.naml$l_long_filename_size = size; \ + nam.naml$l_long_filename = name;} #define rms_get_fna(fab, nam) nam.naml$l_long_filename #define rms_set_dna(fab, nam, name, size) \ - { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \ - nam.naml$l_long_defname_size = size; \ - nam.naml$l_long_defname = name; } + { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \ + nam.naml$l_long_defname_size = size; \ + nam.naml$l_long_defname = name; } #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size #define rms_set_esa(nam, name, size) \ - { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \ - nam.naml$l_long_expand_alloc = size; \ - nam.naml$l_long_expand = name; } + { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \ + nam.naml$l_long_expand_alloc = size; \ + nam.naml$l_long_expand = name; } #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \ - { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \ - nam.naml$l_long_expand = l_name; \ - nam.naml$l_long_expand_alloc = l_size; } + { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \ + nam.naml$l_long_expand = l_name; \ + nam.naml$l_long_expand_alloc = l_size; } #define rms_set_rsa(nam, name, size) \ - { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \ - nam.naml$l_long_result = name; \ - nam.naml$l_long_result_alloc = size; } + { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \ + nam.naml$l_long_result = name; \ + nam.naml$l_long_result_alloc = size; } #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \ - { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \ - nam.naml$l_long_result = l_name; \ - nam.naml$l_long_result_alloc = l_size; } + { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \ + nam.naml$l_long_result = l_name; \ + nam.naml$l_long_result_alloc = l_size; } #define rms_nam_name_type_l_size(nam) \ - (nam.naml$l_long_name_size + nam.naml$l_long_type_size) + (nam.naml$l_long_name_size + nam.naml$l_long_type_size) #endif @@ -5010,8 +5010,8 @@ rms_erase(const char * vmsname) static int vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc, - const struct dsc$descriptor_s * vms_dst_dsc, - unsigned long flags) + const struct dsc$descriptor_s * vms_dst_dsc, + unsigned long flags) { /* VMS and UNIX handle file permissions differently and * the same ACL trick may be needed for renaming files, @@ -5039,31 +5039,31 @@ vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc, unsigned long int myace$l_access; unsigned long int myace$l_ident; } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0, - ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, - 0}, - oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0}; + ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, + 0}, + oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0}; struct item_list_3 - findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0}, - {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0}, - {0,0,0,0}}, - addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}}, - dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0}, - {0,0,0,0}}; + findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0}, + {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0}, + {0,0,0,0}}, + addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}}, + dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0}, + {0,0,0,0}}; /* Expand the input spec using RMS, since we do not want to put * ACLs on the target of a symbolic link */ vmsname = (char *)PerlMem_malloc(NAM$C_MAXRSS+1); if (vmsname == NULL) - return SS$_INSFMEM; + return SS$_INSFMEM; rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer, - vmsname, - PERL_RMSEXPAND_M_SYMLINK); + vmsname, + PERL_RMSEXPAND_M_SYMLINK); if (rslt == NULL) { - PerlMem_free(vmsname); - return SS$_INSFMEM; + PerlMem_free(vmsname); + return SS$_INSFMEM; } /* So we get our own UIC to use as a rights identifier, @@ -5081,91 +5081,91 @@ vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc, /* Grab any existing ACEs with this identifier in case we fail */ clean_dsc = &fildsc; aclsts = fndsts = sys$get_security(&obj_file_dsc, - &fildsc, - NULL, - OSS$M_WLOCK, - findlst, - &ctx, - &access_mode); + &fildsc, + NULL, + OSS$M_WLOCK, + findlst, + &ctx, + &access_mode); if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) { - /* Add the new ACE . . . */ - - /* if the sys$get_security succeeded, then ctx is valid, and the - * object/file descriptors will be ignored. But otherwise they - * are needed - */ - aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL, - OSS$M_RELCTX, addlst, &ctx, &access_mode); - if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) { - set_errno(EVMSERR); - set_vaxc_errno(aclsts); - PerlMem_free(vmsname); - return aclsts; - } - - rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc, - NULL, NULL, - &flags, - NULL, NULL, NULL, NULL, NULL, NULL, NULL); - - if ($VMS_STATUS_SUCCESS(rnsts)) { - clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc; - } - - /* Put things back the way they were. */ - ctx = 0; - aclsts = sys$get_security(&obj_file_dsc, - clean_dsc, - NULL, - OSS$M_WLOCK, - findlst, - &ctx, - &access_mode); - - if ($VMS_STATUS_SUCCESS(aclsts)) { - int sec_flags; - - sec_flags = 0; - if (!$VMS_STATUS_SUCCESS(fndsts)) - sec_flags = OSS$M_RELCTX; - - /* Get rid of the new ACE */ - aclsts = sys$set_security(NULL, NULL, NULL, - sec_flags, dellst, &ctx, &access_mode); - - /* If there was an old ACE, put it back */ - if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) { - addlst[0].bufadr = &oldace; - aclsts = sys$set_security(NULL, NULL, NULL, - OSS$M_RELCTX, addlst, &ctx, &access_mode); - if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) { - set_errno(EVMSERR); - set_vaxc_errno(aclsts); - rnsts = aclsts; - } - } else { - int aclsts2; - - /* Try to clear the lock on the ACL list */ - aclsts2 = sys$set_security(NULL, NULL, NULL, - OSS$M_RELCTX, NULL, &ctx, &access_mode); - - /* Rename errors are most important */ - if (!$VMS_STATUS_SUCCESS(rnsts)) - aclsts = rnsts; - set_errno(EVMSERR); - set_vaxc_errno(aclsts); - rnsts = aclsts; - } - } - else { - if (aclsts != SS$_ACLEMPTY) - rnsts = aclsts; - } + /* Add the new ACE . . . */ + + /* if the sys$get_security succeeded, then ctx is valid, and the + * object/file descriptors will be ignored. But otherwise they + * are needed + */ + aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL, + OSS$M_RELCTX, addlst, &ctx, &access_mode); + if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) { + set_errno(EVMSERR); + set_vaxc_errno(aclsts); + PerlMem_free(vmsname); + return aclsts; + } + + rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc, + NULL, NULL, + &flags, + NULL, NULL, NULL, NULL, NULL, NULL, NULL); + + if ($VMS_STATUS_SUCCESS(rnsts)) { + clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc; + } + + /* Put things back the way they were. */ + ctx = 0; + aclsts = sys$get_security(&obj_file_dsc, + clean_dsc, + NULL, + OSS$M_WLOCK, + findlst, + &ctx, + &access_mode); + + if ($VMS_STATUS_SUCCESS(aclsts)) { + int sec_flags; + + sec_flags = 0; + if (!$VMS_STATUS_SUCCESS(fndsts)) + sec_flags = OSS$M_RELCTX; + + /* Get rid of the new ACE */ + aclsts = sys$set_security(NULL, NULL, NULL, + sec_flags, dellst, &ctx, &access_mode); + + /* If there was an old ACE, put it back */ + if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) { + addlst[0].bufadr = &oldace; + aclsts = sys$set_security(NULL, NULL, NULL, + OSS$M_RELCTX, addlst, &ctx, &access_mode); + if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) { + set_errno(EVMSERR); + set_vaxc_errno(aclsts); + rnsts = aclsts; + } + } else { + int aclsts2; + + /* Try to clear the lock on the ACL list */ + aclsts2 = sys$set_security(NULL, NULL, NULL, + OSS$M_RELCTX, NULL, &ctx, &access_mode); + + /* Rename errors are most important */ + if (!$VMS_STATUS_SUCCESS(rnsts)) + aclsts = rnsts; + set_errno(EVMSERR); + set_vaxc_errno(aclsts); + rnsts = aclsts; + } + } + else { + if (aclsts != SS$_ACLEMPTY) + rnsts = aclsts; + } } else - rnsts = fndsts; + rnsts = fndsts; PerlMem_free(vmsname); return rnsts; @@ -5191,8 +5191,8 @@ Perl_rename(pTHX_ const char *src, const char * dst) src_sts = flex_lstat(src, &src_st); if (src_sts != 0) { - /* No source file or other problem */ - return src_sts; + /* No source file or other problem */ + return src_sts; } if (src_st.st_devnam[0] == 0) { /* This may be possible so fail if it is seen. */ @@ -5203,49 +5203,49 @@ Perl_rename(pTHX_ const char *src, const char * dst) dst_sts = flex_lstat(dst, &dst_st); if (dst_sts == 0) { - if (dst_st.st_dev != src_st.st_dev) { - /* Must be on the same device */ - errno = EXDEV; - return -1; - } + if (dst_st.st_dev != src_st.st_dev) { + /* Must be on the same device */ + errno = EXDEV; + return -1; + } - /* VMS_INO_T_COMPARE is true if the inodes are different - * to match the output of memcmp - */ + /* VMS_INO_T_COMPARE is true if the inodes are different + * to match the output of memcmp + */ - if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) { - /* That was easy, the files are the same! */ - return 0; - } + if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) { + /* That was easy, the files are the same! */ + return 0; + } - if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) { - /* If source is a directory, so must be dest */ - errno = EISDIR; - return -1; - } + if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) { + /* If source is a directory, so must be dest */ + errno = EISDIR; + return -1; + } } if ((dst_sts == 0) && - (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) { - - /* We have issues here if vms_unlink_all_versions is set - * If the destination exists, and is not a directory, then - * we must delete in advance. - * - * If the src is a directory, then we must always pre-delete - * the destination. - * - * If we successfully delete the dst in advance, and the rename fails - * X/Open requires that errno be EIO. - * - */ - - if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) { - int d_sts; - d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, - S_ISDIR(dst_st.st_mode)); + (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) { + + /* We have issues here if vms_unlink_all_versions is set + * If the destination exists, and is not a directory, then + * we must delete in advance. + * + * If the src is a directory, then we must always pre-delete + * the destination. + * + * If we successfully delete the dst in advance, and the rename fails + * X/Open requires that errno be EIO. + * + */ + + if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) { + int d_sts; + d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, + S_ISDIR(dst_st.st_mode)); /* Need to delete all versions ? */ if ((d_sts == 0) && (vms_unlink_all_versions == 1)) { @@ -5266,12 +5266,12 @@ Perl_rename(pTHX_ const char *src, const char * dst) } } - if (d_sts != 0) - return d_sts; + if (d_sts != 0) + return d_sts; - /* We killed the destination, so only errno now is EIO */ - pre_delete = 1; - } + /* We killed the destination, so only errno now is EIO */ + pre_delete = 1; + } } /* Originally the idea was to call the CRTL rename() and only @@ -5282,171 +5282,171 @@ Perl_rename(pTHX_ const char *src, const char * dst) retval = -1; { - /* Is the source and dest both in VMS format */ - /* if the source is a directory, then need to fileify */ - /* and dest must be a directory or non-existent. */ - - char * vms_dst; - int sts; - char * ret_str; - unsigned long flags; - struct dsc$descriptor_s old_file_dsc; - struct dsc$descriptor_s new_file_dsc; - - /* We need to modify the src and dst depending - * on if one or more of them are directories. - */ - - vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS); - if (vms_dst == NULL) - _ckvmssts_noperl(SS$_INSFMEM); - - if (S_ISDIR(src_st.st_mode)) { - char * ret_str; - char * vms_dir_file; - - vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS); - if (vms_dir_file == NULL) - _ckvmssts_noperl(SS$_INSFMEM); - - /* If the dest is a directory, we must remove it */ - if (dst_sts == 0) { - int d_sts; - d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1); - if (d_sts != 0) { - PerlMem_free(vms_dst); - errno = EIO; - return d_sts; - } - - pre_delete = 1; - } - - /* The dest must be a VMS file specification */ - ret_str = int_tovmsspec(dst, vms_dst, 0, NULL); - if (ret_str == NULL) { - PerlMem_free(vms_dst); - errno = EIO; - return -1; - } - - /* The source must be a file specification */ - ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL); - if (ret_str == NULL) { - PerlMem_free(vms_dst); - PerlMem_free(vms_dir_file); - errno = EIO; - return -1; - } - PerlMem_free(vms_dst); - vms_dst = vms_dir_file; - - } else { - /* File to file or file to new dir */ - - if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) { - /* VMS pathify a dir target */ - ret_str = int_tovmspath(dst, vms_dst, NULL); - if (ret_str == NULL) { - PerlMem_free(vms_dst); - errno = EIO; - return -1; - } - } else { + /* Is the source and dest both in VMS format */ + /* if the source is a directory, then need to fileify */ + /* and dest must be a directory or non-existent. */ + + char * vms_dst; + int sts; + char * ret_str; + unsigned long flags; + struct dsc$descriptor_s old_file_dsc; + struct dsc$descriptor_s new_file_dsc; + + /* We need to modify the src and dst depending + * on if one or more of them are directories. + */ + + vms_dst = (char *)PerlMem_malloc(VMS_MAXRSS); + if (vms_dst == NULL) + _ckvmssts_noperl(SS$_INSFMEM); + + if (S_ISDIR(src_st.st_mode)) { + char * ret_str; + char * vms_dir_file; + + vms_dir_file = (char *)PerlMem_malloc(VMS_MAXRSS); + if (vms_dir_file == NULL) + _ckvmssts_noperl(SS$_INSFMEM); + + /* If the dest is a directory, we must remove it */ + if (dst_sts == 0) { + int d_sts; + d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1); + if (d_sts != 0) { + PerlMem_free(vms_dst); + errno = EIO; + return d_sts; + } + + pre_delete = 1; + } + + /* The dest must be a VMS file specification */ + ret_str = int_tovmsspec(dst, vms_dst, 0, NULL); + if (ret_str == NULL) { + PerlMem_free(vms_dst); + errno = EIO; + return -1; + } + + /* The source must be a file specification */ + ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL); + if (ret_str == NULL) { + PerlMem_free(vms_dst); + PerlMem_free(vms_dir_file); + errno = EIO; + return -1; + } + PerlMem_free(vms_dst); + vms_dst = vms_dir_file; + + } else { + /* File to file or file to new dir */ + + if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) { + /* VMS pathify a dir target */ + ret_str = int_tovmspath(dst, vms_dst, NULL); + if (ret_str == NULL) { + PerlMem_free(vms_dst); + errno = EIO; + return -1; + } + } else { char * v_spec, * r_spec, * d_spec, * n_spec; char * e_spec, * vs_spec; int sts, v_len, r_len, d_len, n_len, e_len, vs_len; - /* fileify a target VMS file specification */ - ret_str = int_tovmsspec(dst, vms_dst, 0, NULL); - if (ret_str == NULL) { - PerlMem_free(vms_dst); - errno = EIO; - return -1; - } + /* fileify a target VMS file specification */ + ret_str = int_tovmsspec(dst, vms_dst, 0, NULL); + if (ret_str == NULL) { + PerlMem_free(vms_dst); + errno = EIO; + return -1; + } - sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len, + sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len, &d_spec, &d_len, &n_spec, &n_len, &e_spec, &e_len, &vs_spec, &vs_len); - if (sts == 0) { - if (e_len == 0) { - /* Get rid of the version */ - if (vs_len != 0) { - *vs_spec = '\0'; - } - /* Need to specify a '.' so that the extension */ - /* is not inherited */ - strcat(vms_dst,"."); - } - } - } - } - - old_file_dsc.dsc$a_pointer = src_st.st_devnam; - old_file_dsc.dsc$w_length = strlen(src_st.st_devnam); - old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T; - old_file_dsc.dsc$b_class = DSC$K_CLASS_S; - - new_file_dsc.dsc$a_pointer = vms_dst; - new_file_dsc.dsc$w_length = strlen(vms_dst); - new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T; - new_file_dsc.dsc$b_class = DSC$K_CLASS_S; - - flags = 0; + if (sts == 0) { + if (e_len == 0) { + /* Get rid of the version */ + if (vs_len != 0) { + *vs_spec = '\0'; + } + /* Need to specify a '.' so that the extension */ + /* is not inherited */ + strcat(vms_dst,"."); + } + } + } + } + + old_file_dsc.dsc$a_pointer = src_st.st_devnam; + old_file_dsc.dsc$w_length = strlen(src_st.st_devnam); + old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + old_file_dsc.dsc$b_class = DSC$K_CLASS_S; + + new_file_dsc.dsc$a_pointer = vms_dst; + new_file_dsc.dsc$w_length = strlen(vms_dst); + new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + new_file_dsc.dsc$b_class = DSC$K_CLASS_S; + + flags = 0; #if defined(NAML$C_MAXRSS) - flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */ + flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */ #endif - sts = lib$rename_file(&old_file_dsc, - &new_file_dsc, - NULL, NULL, - &flags, - NULL, NULL, NULL, NULL, NULL, NULL, NULL); - if (!$VMS_STATUS_SUCCESS(sts)) { - - /* We could have failed because VMS style permissions do not - * permit renames that UNIX will allow. Just like the hack - * in for kill_file. - */ - sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags); - } + sts = lib$rename_file(&old_file_dsc, + &new_file_dsc, + NULL, NULL, + &flags, + NULL, NULL, NULL, NULL, NULL, NULL, NULL); + if (!$VMS_STATUS_SUCCESS(sts)) { + + /* We could have failed because VMS style permissions do not + * permit renames that UNIX will allow. Just like the hack + * in for kill_file. + */ + sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags); + } - PerlMem_free(vms_dst); - if (!$VMS_STATUS_SUCCESS(sts)) { - errno = EIO; - return -1; - } - retval = 0; + PerlMem_free(vms_dst); + if (!$VMS_STATUS_SUCCESS(sts)) { + errno = EIO; + return -1; + } + retval = 0; } if (vms_unlink_all_versions) { - /* Now get rid of any previous versions of the source file that - * might still exist - */ - int i = 0; - dSAVEDERRNO; - SAVE_ERRNO; - src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam, - S_ISDIR(src_st.st_mode)); - while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) { - src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam, - S_ISDIR(src_st.st_mode)); - if (src_sts != 0) - break; - i++; - - /* Make sure that we do not loop forever */ - if (i > 32767) { - src_sts = -1; - break; - } - } - RESTORE_ERRNO; + /* Now get rid of any previous versions of the source file that + * might still exist + */ + int i = 0; + dSAVEDERRNO; + SAVE_ERRNO; + src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam, + S_ISDIR(src_st.st_mode)); + while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) { + src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam, + S_ISDIR(src_st.st_mode)); + if (src_sts != 0) + break; + i++; + + /* Make sure that we do not loop forever */ + if (i > 32767) { + src_sts = -1; + break; + } + } + RESTORE_ERRNO; } /* We deleted the destination, so must force the error to be EIO */ if ((retval != 0) && (pre_delete != 0)) - errno = EIO; + errno = EIO; return retval; } @@ -5620,14 +5620,14 @@ int_rmsexpand /*----------------------------------------------*/ sts = rms_free_search_context(&myfab); /* Free search context */ if (vmsdefspec != NULL) - PerlMem_free(vmsdefspec); + PerlMem_free(vmsdefspec); if (vmsfspec != NULL) - PerlMem_free(vmsfspec); + PerlMem_free(vmsfspec); if (outbufl != NULL) - PerlMem_free(outbufl); + PerlMem_free(outbufl); PerlMem_free(esa); if (esal != NULL) - PerlMem_free(esal); + PerlMem_free(esal); set_vaxc_errno(retsts); if (retsts == RMS$_PRV) set_errno(EACCES); else if (retsts == RMS$_DEV) set_errno(ENODEV); @@ -5639,14 +5639,14 @@ int_rmsexpand if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) { sts = rms_free_search_context(&myfab); /* Free search context */ if (vmsdefspec != NULL) - PerlMem_free(vmsdefspec); + PerlMem_free(vmsdefspec); if (vmsfspec != NULL) - PerlMem_free(vmsfspec); + PerlMem_free(vmsfspec); if (outbufl != NULL) - PerlMem_free(outbufl); + PerlMem_free(outbufl); PerlMem_free(esa); if (esal != NULL) - PerlMem_free(esal); + PerlMem_free(esal); set_vaxc_errno(retsts); if (retsts == RMS$_PRV) set_errno(EACCES); else set_errno(EVMSERR); @@ -5668,23 +5668,23 @@ int_expanded: #if defined(NAML$C_MAXRSS) if ((opts & PERL_RMSEXPAND_M_LONG) != 0) { if (rms_nam_rsll(mynam)) { - spec_buf = outbufl; - speclen = rms_nam_rsll(mynam); + spec_buf = outbufl; + speclen = rms_nam_rsll(mynam); } else { - spec_buf = esal; /* Not esa */ - speclen = rms_nam_esll(mynam); + spec_buf = esal; /* Not esa */ + speclen = rms_nam_esll(mynam); } } else { #endif if (rms_nam_rsl(mynam)) { - spec_buf = outbuf; - speclen = rms_nam_rsl(mynam); + spec_buf = outbuf; + speclen = rms_nam_rsl(mynam); } else { - spec_buf = esa; /* Not esal */ - speclen = rms_nam_esl(mynam); + spec_buf = esa; /* Not esal */ + speclen = rms_nam_esl(mynam); } #if defined(NAML$C_MAXRSS) } @@ -5715,69 +5715,69 @@ int_expanded: defesal = (char *)PerlMem_malloc(VMS_MAXRSS + 1); if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM); #endif - rms_setup_nam(defnam); + rms_setup_nam(defnam); - rms_bind_fab_nam(deffab, defnam); + rms_bind_fab_nam(deffab, defnam); - /* Cast ok */ - rms_set_fna - (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam)); + /* Cast ok */ + rms_set_fna + (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam)); - /* RMS needs the esa/esal as a work area if wildcards are involved */ - rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1); + /* RMS needs the esa/esal as a work area if wildcards are involved */ + rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1); - rms_clear_nam_nop(defnam); - rms_set_nam_nop(defnam, NAM$M_SYNCHK); + rms_clear_nam_nop(defnam); + rms_set_nam_nop(defnam, NAM$M_SYNCHK); #ifdef NAM$M_NO_SHORT_UPCASE - if (DECC_EFS_CASE_PRESERVE) - rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE); + if (DECC_EFS_CASE_PRESERVE) + rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE); #endif #ifdef NAML$M_OPEN_SPECIAL - if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0) - rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL); + if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0) + rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL); #endif - if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) { - if (trimver) { - trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER); - } - if (trimtype) { - trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE); - } - } - if (defesal != NULL) - PerlMem_free(defesal); - PerlMem_free(defesa); + if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) { + if (trimver) { + trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER); + } + if (trimtype) { + trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE); + } + } + if (defesal != NULL) + PerlMem_free(defesal); + PerlMem_free(defesa); } else { _ckvmssts_noperl(SS$_INSFMEM); } } if (trimver) { if ((opts & PERL_RMSEXPAND_M_LONG) != 0) { - if (*(rms_nam_verl(mynam)) != '\"') - speclen = rms_nam_verl(mynam) - spec_buf; + if (*(rms_nam_verl(mynam)) != '\"') + speclen = rms_nam_verl(mynam) - spec_buf; } else { - if (*(rms_nam_ver(mynam)) != '\"') - speclen = rms_nam_ver(mynam) - spec_buf; + if (*(rms_nam_ver(mynam)) != '\"') + speclen = rms_nam_ver(mynam) - spec_buf; } } if (trimtype) { /* If we didn't already trim version, copy down */ if ((opts & PERL_RMSEXPAND_M_LONG) != 0) { - if (speclen > rms_nam_verl(mynam) - spec_buf) - memmove - (rms_nam_typel(mynam), - rms_nam_verl(mynam), - speclen - (rms_nam_verl(mynam) - spec_buf)); - speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam); + if (speclen > rms_nam_verl(mynam) - spec_buf) + memmove + (rms_nam_typel(mynam), + rms_nam_verl(mynam), + speclen - (rms_nam_verl(mynam) - spec_buf)); + speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam); } else { - if (speclen > rms_nam_ver(mynam) - spec_buf) - memmove - (rms_nam_type(mynam), - rms_nam_ver(mynam), - speclen - (rms_nam_ver(mynam) - spec_buf)); - speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam); + if (speclen > rms_nam_ver(mynam) - spec_buf) + memmove + (rms_nam_type(mynam), + rms_nam_ver(mynam), + speclen - (rms_nam_ver(mynam) - spec_buf)); + speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam); } } } @@ -5785,25 +5785,25 @@ int_expanded: /* Done with these copies of the input files */ /*-------------------------------------------*/ if (vmsfspec != NULL) - PerlMem_free(vmsfspec); + PerlMem_free(vmsfspec); if (vmsdefspec != NULL) - PerlMem_free(vmsdefspec); + PerlMem_free(vmsdefspec); /* If we just had a directory spec on input, $PARSE "helpfully" * adds an empty name and type for us */ #if defined(NAML$C_MAXRSS) if ((opts & PERL_RMSEXPAND_M_LONG) != 0) { if (rms_nam_namel(mynam) == rms_nam_typel(mynam) && - rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 && - !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME))) + rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 && + !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME))) speclen = rms_nam_namel(mynam) - spec_buf; } else #endif { if (rms_nam_name(mynam) == rms_nam_type(mynam) && - rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 && - !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME))) + rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 && + !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME))) speclen = rms_nam_name(mynam) - spec_buf; } @@ -6020,7 +6020,7 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) unsigned short int trnlnm_iter_count; int sts; if (utf8_fl != NULL) - *utf8_fl = 0; + *utf8_fl = 0; if (!dir || !*dir) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; @@ -6033,7 +6033,7 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) dirlen = 9; } else - dirlen = 1; + dirlen = 1; } if (dirlen > (VMS_MAXRSS - 1)) { set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); @@ -6042,7 +6042,7 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) trndir = (char *)PerlMem_malloc(VMS_MAXRSS + 1); if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM); if (!strpbrk(dir+1,"/]>:") && - (!DECC_POSIX_COMPLIANT_PATHNAMES && DECC_DISABLE_POSIX_ROOT)) { + (!DECC_POSIX_COMPLIANT_PATHNAMES && DECC_DISABLE_POSIX_ROOT)) { strcpy(trndir,*dir == '/' ? dir + 1: dir); trnlnm_iter_count = 0; while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) { @@ -6082,13 +6082,13 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) of explicit directories in a VMS spec which ends with directories. */ else { for (cp2 = cp1; cp2 > trndir; cp2--) { - if (*cp2 == '.') { - if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) { + if (*cp2 == '.') { + if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) { /* fix-me, can not scan EFS file specs backward like this */ *cp2 = *cp1; *cp1 = '\0'; hasfilename = 1; - break; - } + break; + } } if (*cp2 == '[' || *cp2 == '<') break; } @@ -6105,16 +6105,16 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) if (trndir[0] == '.') { if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) { - PerlMem_free(trndir); - PerlMem_free(vmsdir); + PerlMem_free(trndir); + PerlMem_free(vmsdir); return int_fileify_dirspec("[]", buf, NULL); - } + } else if (trndir[1] == '.' && (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) { - PerlMem_free(trndir); - PerlMem_free(vmsdir); + PerlMem_free(trndir); + PerlMem_free(vmsdir); return int_fileify_dirspec("[-]", buf, NULL); - } + } } if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ dirlen -= 1; /* to last element */ @@ -6127,31 +6127,31 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) do { if (*(cp1+2) == '.') cp1++; if (*(cp1+2) == '/' || *(cp1+2) == '\0') { - char * ret_chr; + char * ret_chr; if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) { - PerlMem_free(trndir); - PerlMem_free(vmsdir); - return NULL; - } + PerlMem_free(trndir); + PerlMem_free(vmsdir); + return NULL; + } if (strchr(vmsdir,'/') != NULL) { /* If int_tovmsspec() returned it, it must have VMS syntax * delimiters in it, so it's a mixed VMS/Unix spec. We take * the time to check this here only so we avoid a recursion * loop; otherwise, gigo. */ - PerlMem_free(trndir); - PerlMem_free(vmsdir); + PerlMem_free(trndir); + PerlMem_free(vmsdir); set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); - return NULL; + return NULL; } if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) { - PerlMem_free(trndir); - PerlMem_free(vmsdir); - return NULL; - } - ret_chr = int_tounixspec(trndir, buf, utf8_fl); - PerlMem_free(trndir); - PerlMem_free(vmsdir); + PerlMem_free(trndir); + PerlMem_free(vmsdir); + return NULL; + } + ret_chr = int_tounixspec(trndir, buf, utf8_fl); + PerlMem_free(trndir); + PerlMem_free(vmsdir); return ret_chr; } cp1++; @@ -6159,7 +6159,7 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) lastdir = strrchr(trndir,'/'); } else if (dirlen >= 7 && strEQ(&trndir[dirlen-7],"/000000")) { - char * ret_chr; + char * ret_chr; /* Ditto for specs that end in an MFD -- let the VMS code * figure out whether it's a real device or a rooted logical. */ @@ -6171,18 +6171,18 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) trndir[dirlen] = '/'; trndir[dirlen+1] = '\0'; if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) { - PerlMem_free(trndir); - PerlMem_free(vmsdir); - return NULL; - } + PerlMem_free(trndir); + PerlMem_free(vmsdir); + return NULL; + } if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) { - PerlMem_free(trndir); - PerlMem_free(vmsdir); - return NULL; - } - ret_chr = int_tounixspec(trndir, buf, utf8_fl); - PerlMem_free(trndir); - PerlMem_free(vmsdir); + PerlMem_free(trndir); + PerlMem_free(vmsdir); + return NULL; + } + ret_chr = int_tounixspec(trndir, buf, utf8_fl); + PerlMem_free(trndir); + PerlMem_free(vmsdir); return ret_chr; } else { @@ -6230,7 +6230,7 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) memmove(cp4 + 1, cp4, trndir + dirlen - cp4 + 1); *cp4 = '^'; dirlen++; - } + } } } } @@ -6277,7 +6277,7 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1)); #ifdef NAM$M_NO_SHORT_UPCASE if (DECC_EFS_CASE_PRESERVE) - rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE); + rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE); #endif for (cp = trndir; *cp; cp++) @@ -6290,11 +6290,11 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) sts = sys$parse(&dirfab); } if (!sts) { - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - PerlMem_free(trndir); - PerlMem_free(vmsdir); + PerlMem_free(esa); + if (esal != NULL) + PerlMem_free(esal); + PerlMem_free(trndir); + PerlMem_free(vmsdir); set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); return NULL; @@ -6302,7 +6302,7 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) } else { savnam = dirnam; - /* Does the file really exist? */ + /* Does the file really exist? */ if (sys$search(&dirfab)& STS$K_SUCCESS) { /* Yes; fake the fnb bits so we'll check type below */ rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER)); @@ -6313,14 +6313,14 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) || dirfab.fab$l_sts == RMS$_FND) dirnam = savnam; else { - int fab_sts; - fab_sts = dirfab.fab$l_sts; - sts = rms_free_search_context(&dirfab); - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - PerlMem_free(trndir); - PerlMem_free(vmsdir); + int fab_sts; + fab_sts = dirfab.fab$l_sts; + sts = rms_free_search_context(&dirfab); + PerlMem_free(esa); + if (esal != NULL) + PerlMem_free(esal); + PerlMem_free(trndir); + PerlMem_free(vmsdir); set_errno(EVMSERR); set_vaxc_errno(fab_sts); return NULL; } @@ -6330,11 +6330,11 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) /* Make sure we are using the right buffer */ #if defined(NAML$C_MAXRSS) if (esal != NULL) { - my_esa = esal; - my_esa_len = rms_nam_esll(dirnam); + my_esa = esal; + my_esa_len = rms_nam_esll(dirnam); } else { #endif - my_esa = esa; + my_esa = esa; my_esa_len = rms_nam_esl(dirnam); #if defined(NAML$C_MAXRSS) } @@ -6353,12 +6353,12 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4; if (strnNE(rms_nam_typel(dirnam), ".DIR;1", cmplen)) { /* Something other than .DIR[;1]. Bzzt. */ - sts = rms_free_search_context(&dirfab); - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - PerlMem_free(trndir); - PerlMem_free(vmsdir); + sts = rms_free_search_context(&dirfab); + PerlMem_free(esa); + if (esal != NULL) + PerlMem_free(esal); + PerlMem_free(trndir); + PerlMem_free(vmsdir); set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR); return NULL; @@ -6368,12 +6368,12 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) { /* They provided at least the name; we added the type, if necessary, */ my_strlcpy(buf, my_esa, VMS_MAXRSS); - sts = rms_free_search_context(&dirfab); - PerlMem_free(trndir); - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - PerlMem_free(vmsdir); + sts = rms_free_search_context(&dirfab); + PerlMem_free(trndir); + PerlMem_free(esa); + if (esal != NULL) + PerlMem_free(esal); + PerlMem_free(vmsdir); return buf; } if ((cp1 = strstr(esa,".][000000]")) != NULL) { @@ -6383,12 +6383,12 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) } if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>'); if (cp1 == NULL) { /* should never happen */ - sts = rms_free_search_context(&dirfab); - PerlMem_free(trndir); - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - PerlMem_free(vmsdir); + sts = rms_free_search_context(&dirfab); + PerlMem_free(trndir); + PerlMem_free(esa); + if (esal != NULL) + PerlMem_free(esal); + PerlMem_free(vmsdir); return NULL; } term = *cp1; @@ -6399,14 +6399,14 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) /* Fix-me, can not scan EFS file specifications backwards */ while (cp1 != NULL) { if ((cp1-1 == my_esa) || (*(cp1-1) != '^')) - break; - else { - cp1--; - while ((cp1 > my_esa) && (*cp1 != '.')) - cp1--; - } - if (cp1 == my_esa) - cp1 = NULL; + break; + else { + cp1--; + while ((cp1 > my_esa) && (*cp1 != '.')) + cp1--; + } + if (cp1 == my_esa) + cp1 = NULL; } if ((cp1) != NULL) { @@ -6419,27 +6419,27 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) /* Go back and expand rooted logical name */ rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL); #ifdef NAM$M_NO_SHORT_UPCASE - if (DECC_EFS_CASE_PRESERVE) - rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE); + if (DECC_EFS_CASE_PRESERVE) + rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE); #endif if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) { - sts = rms_free_search_context(&dirfab); - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - PerlMem_free(trndir); - PerlMem_free(vmsdir); + sts = rms_free_search_context(&dirfab); + PerlMem_free(esa); + if (esal != NULL) + PerlMem_free(esal); + PerlMem_free(trndir); + PerlMem_free(vmsdir); set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts); return NULL; } - /* This changes the length of the string of course */ - if (esal != NULL) { - my_esa_len = rms_nam_esll(dirnam); - } else { - my_esa_len = rms_nam_esl(dirnam); - } + /* This changes the length of the string of course */ + if (esal != NULL) { + my_esa_len = rms_nam_esll(dirnam); + } else { + my_esa_len = rms_nam_esl(dirnam); + } retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */ cp1 = strstr(my_esa,"]["); @@ -6448,18 +6448,18 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) memcpy(buf, my_esa, dirlen); if (strBEGINs(cp1+2,"000000]")) { buf[dirlen-1] = '\0'; - /* fix-me Not full ODS-5, just extra dots in directories for now */ - cp1 = buf + dirlen - 1; - while (cp1 > buf) - { - if (*cp1 == '[') - break; - if (*cp1 == '.') { - if (*(cp1-1) != '^') - break; - } - cp1--; - } + /* fix-me Not full ODS-5, just extra dots in directories for now */ + cp1 = buf + dirlen - 1; + while (cp1 > buf) + { + if (*cp1 == '[') + break; + if (*cp1 == '.') { + if (*(cp1-1) != '^') + break; + } + cp1--; + } if (*cp1 == '.') *cp1 = ']'; else { memmove(cp1+8, cp1+1, buf+dirlen-cp1); @@ -6471,14 +6471,14 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) buf[retlen] = '\0'; /* Convert last '.' to ']' */ cp1 = buf+retlen-1; - while (*cp != '[') { - cp1--; - if (*cp1 == '.') { - /* Do not trip on extra dots in ODS-5 directories */ - if ((cp1 == buf) || (*(cp1-1) != '^')) - break; - } - } + while (*cp != '[') { + cp1--; + if (*cp1 == '.') { + /* Do not trip on extra dots in ODS-5 directories */ + if ((cp1 == buf) || (*(cp1-1) != '^')) + break; + } + } if (*cp1 == '.') *cp1 = ']'; else { memmove(cp1+8, cp1+1, buf+dirlen-cp1); @@ -6506,7 +6506,7 @@ int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl) PerlMem_free(trndir); PerlMem_free(esa); if (esal != NULL) - PerlMem_free(esal); + PerlMem_free(esal); PerlMem_free(vmsdir); return buf; } @@ -7062,23 +7062,23 @@ int_tounixspec(const char *spec, char *rslt, int * utf8_fl) tunix_len = my_strlcpy(tunix, spec, VMS_MAXRSS); nl_flag = 0; if (tunix[tunix_len - 1] == '\n') { - tunix[tunix_len - 1] = '\"'; - tunix[tunix_len] = '\0'; - tunix_len--; - nl_flag = 1; + tunix[tunix_len - 1] = '\"'; + tunix[tunix_len] = '\0'; + tunix_len--; + nl_flag = 1; } uspec = decc$translate_vms(tunix); PerlMem_free(tunix); if ((int)uspec > 0) { - my_strlcpy(rslt, uspec, VMS_MAXRSS); - if (nl_flag) { - strcat(rslt,"\n"); - } - else { - /* If we can not translate it, makemaker wants as-is */ - my_strlcpy(rslt, spec, VMS_MAXRSS); - } - return rslt; + my_strlcpy(rslt, uspec, VMS_MAXRSS); + if (nl_flag) { + strcat(rslt,"\n"); + } + else { + /* If we can not translate it, makemaker wants as-is */ + my_strlcpy(rslt, spec, VMS_MAXRSS); + } + return rslt; } } } @@ -7091,12 +7091,12 @@ int_tounixspec(const char *spec, char *rslt, int * utf8_fl) /* Look for EFS ^/ */ if (DECC_EFS_CHARSET) { while (cp1 != NULL) { - cp2 = cp1 - 1; - if (*cp2 != '^') { - /* Found illegal VMS, assume UNIX */ - cmp_rslt = 1; - break; - } + cp2 = cp1 - 1; + if (*cp2 != '^') { + /* Found illegal VMS, assume UNIX */ + cmp_rslt = 1; + break; + } cp1++; cp1 = strchr(cp1, '/'); } @@ -7106,12 +7106,12 @@ int_tounixspec(const char *spec, char *rslt, int * utf8_fl) if (DECC_FILENAME_UNIX_REPORT) { if (spec[0] == '.') { if ((spec[1] == '\0') || (spec[1] == '\n')) { - cmp_rslt = 1; + cmp_rslt = 1; } else { - if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) { - cmp_rslt = 1; - } + if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) { + cmp_rslt = 1; + } } } } @@ -7184,9 +7184,9 @@ int_tounixspec(const char *spec, char *rslt, int * utf8_fl) cp1 = cp1 + 4; cp2 = cp2 + 12; if (spec[12] != '\0') { - cp1[4] = '/'; - cp1++; - cp2++; + cp1[4] = '/'; + cp1++; + cp2++; } } } @@ -7202,7 +7202,7 @@ int_tounixspec(const char *spec, char *rslt, int * utf8_fl) } else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */ if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) { - PerlMem_free(tmp); + PerlMem_free(tmp); if (vms_debug_fileify) { fprintf(stderr, "int_tounixspec: rslt = NULL\n"); } @@ -7223,14 +7223,14 @@ int_tounixspec(const char *spec, char *rslt, int * utf8_fl) while (*cp3) { *(cp1++) = *(cp3++); if (cp1 - rslt > (VMS_MAXRSS - 1)) { - PerlMem_free(tmp); + PerlMem_free(tmp); set_errno(ENAMETOOLONG); set_vaxc_errno(SS$_BUFFEROVF); if (vms_debug_fileify) { fprintf(stderr, "int_tounixspec: rslt = NULL\n"); } - return NULL; /* No room */ - } + return NULL; /* No room */ + } } *(cp1++) = '/'; } @@ -7368,14 +7368,14 @@ int_tounixspec(const char *spec, char *rslt, int * utf8_fl) /* Get rid of "000000/ in rooted filespecs */ if (ulen > 7) { - zeros = strstr(rslt, "/000000/"); - if (zeros != NULL) { - int mlen; - mlen = ulen - (zeros - rslt) - 7; - memmove(zeros, &zeros[7], mlen); - ulen = ulen - 7; - rslt[ulen] = '\0'; - } + zeros = strstr(rslt, "/000000/"); + if (zeros != NULL) { + int mlen; + mlen = ulen - (zeros - rslt) - 7; + memmove(zeros, &zeros[7], mlen); + ulen = ulen - 7; + rslt[ulen] = '\0'; + } } } @@ -7499,13 +7499,13 @@ posix_root_to_vms(char *vmspath, int vmspath_len, /* Check to see if this is under the POSIX root */ if (DECC_DISABLE_POSIX_ROOT) { - return RMS$_FNF; + return RMS$_FNF; } /* Skip leading / */ if (unixpath[0] == '/') { - unixpath++; - unixlen--; + unixpath++; + unixlen--; } @@ -7513,8 +7513,8 @@ posix_root_to_vms(char *vmspath, int vmspath_len, /* If this is only the / , or blank, then... */ if (unixpath[0] == '\0') { - /* by definition, this is the answer */ - return SS$_NORMAL; + /* by definition, this is the answer */ + return SS$_NORMAL; } /* Need to look up a directory */ @@ -7527,18 +7527,18 @@ posix_root_to_vms(char *vmspath, int vmspath_len, while (unixpath[i] != 0) { int k; - j += copy_expand_unix_filename_escape - (&vmspath[j], &unixpath[i], &k, utf8_fl); - i += k; + j += copy_expand_unix_filename_escape + (&vmspath[j], &unixpath[i], &k, utf8_fl); + i += k; } path_len = strlen(vmspath); if (vmspath[path_len - 1] == '/') - path_len--; + path_len--; vmspath[path_len] = ']'; path_len++; vmspath[path_len] = '\0'; - + } vmspath[vmspath_len] = 0; if (unixpath[unixlen - 1] == '/') @@ -7615,45 +7615,45 @@ posix_root_to_vms(char *vmspath, int vmspath_len, i = specdsc.dsc$w_length - 1; while (i > 0) { int zercnt; - zercnt = 0; - /* Version must be '1' */ - if (vmspath[i--] != '1') - break; - /* Version delimiter is one of ".;" */ - if ((vmspath[i] != '.') && (vmspath[i] != ';')) - break; - i--; - if (vmspath[i--] != 'R') - break; - if (vmspath[i--] != 'I') - break; - if (vmspath[i--] != 'D') - break; - if (vmspath[i--] != '.') - break; - eptr = &vmspath[i+1]; - while (i > 0) { - if ((vmspath[i] == ']') || (vmspath[i] == '>')) { - if (vmspath[i-1] != '^') { - if (zercnt != 6) { - *eptr = vmspath[i]; - eptr[1] = '\0'; - vmspath[i] = '.'; - break; - } - else { - /* Get rid of 6 imaginary zero directory filename */ - vmspath[i+1] = '\0'; - } - } - } - if (vmspath[i] == '0') - zercnt++; - else - zercnt = 10; - i--; - } - break; + zercnt = 0; + /* Version must be '1' */ + if (vmspath[i--] != '1') + break; + /* Version delimiter is one of ".;" */ + if ((vmspath[i] != '.') && (vmspath[i] != ';')) + break; + i--; + if (vmspath[i--] != 'R') + break; + if (vmspath[i--] != 'I') + break; + if (vmspath[i--] != 'D') + break; + if (vmspath[i--] != '.') + break; + eptr = &vmspath[i+1]; + while (i > 0) { + if ((vmspath[i] == ']') || (vmspath[i] == '>')) { + if (vmspath[i-1] != '^') { + if (zercnt != 6) { + *eptr = vmspath[i]; + eptr[1] = '\0'; + vmspath[i] = '.'; + break; + } + else { + /* Get rid of 6 imaginary zero directory filename */ + vmspath[i+1] = '\0'; + } + } + } + if (vmspath[i] == '0') + zercnt++; + else + zercnt = 10; + i--; + } + break; } } } @@ -7676,12 +7676,12 @@ slash_dev_special_to_vms(const char *unixptr, char *vmspath, int vmspath_len) nextslash = strchr(unixptr, '/'); len = strlen(unixptr); if (nextslash != NULL) - len = nextslash - unixptr; + len = nextslash - unixptr; if (strEQ(unixptr, "null")) { - if (vmspath_len >= 6) { - strcpy(vmspath, "_NLA0:"); - return SS$_NORMAL; - } + if (vmspath_len >= 6) { + strcpy(vmspath, "_NLA0:"); + return SS$_NORMAL; + } } return 0; } @@ -7786,151 +7786,151 @@ posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath, /* If allowing logical names on relative pathnames, then handle here */ if ((unixptr[0] != '.') && !DECC_DISABLE_TO_VMS_LOGNAME_TRANSLATION && - !DECC_POSIX_COMPLIANT_PATHNAMES) { + !DECC_POSIX_COMPLIANT_PATHNAMES) { char * nextslash; int seg_len; char * trn; int islnm; - /* Find the next slash */ - nextslash = strchr(unixptr,'/'); - - esa = (char *)PerlMem_malloc(vmspath_len); - if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM); - - trn = (char *)PerlMem_malloc(VMS_MAXRSS); - if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM); - - if (nextslash != NULL) { - - seg_len = nextslash - unixptr; - memcpy(esa, unixptr, seg_len); - esa[seg_len] = 0; - } - else { - seg_len = my_strlcpy(esa, unixptr, sizeof(esa)); - } - /* trnlnm(section) */ - islnm = vmstrnenv(esa, trn, 0, fildev, 0); - - if (islnm) { - /* Now fix up the directory */ - - /* Split up the path to find the components */ - sts = vms_split_path - (trn, - &v_spec, - &v_len, - &r_spec, - &r_len, - &d_spec, - &d_len, - &n_spec, - &n_len, - &e_spec, - &e_len, - &vs_spec, - &vs_len); - - while (sts == 0) { - - /* A logical name must be a directory or the full - specification. It is only a full specification if - it is the only component */ - if ((unixptr[seg_len] == '\0') || - (unixptr[seg_len+1] == '\0')) { - - /* Is a directory being required? */ - if (((n_len + e_len) != 0) && (dir_flag !=0)) { - /* Not a logical name */ - break; - } - - - if ((unixptr[seg_len] == '/') || (dir_flag != 0)) { - /* This must be a directory */ - if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) { - vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1); - vmsptr[vmslen] = ':'; - vmslen++; - vmsptr[vmslen] = '\0'; - return SS$_NORMAL; - } - } - - } - - - /* must be dev/directory - ignore version */ - if ((n_len + e_len) != 0) - break; - - /* transfer the volume */ - if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) { - memcpy(vmsptr, v_spec, v_len); - vmsptr += v_len; - vmsptr[0] = '\0'; - vmslen += v_len; - } - - /* unroot the rooted directory */ - if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) { - r_spec[0] = '['; - r_spec[r_len - 1] = ']'; - - /* This should not be there, but nothing is perfect */ - if (r_len > 9) { - if (strEQ(&r_spec[1], "000000.")) { - r_spec += 7; - r_spec[7] = '['; - r_len -= 7; - if (r_len == 2) - r_len = 0; - } - } - if (r_len > 0) { - memcpy(vmsptr, r_spec, r_len); - vmsptr += r_len; - vmslen += r_len; - vmsptr[0] = '\0'; - } - } - /* Bring over the directory. */ - if ((d_len > 0) && - ((d_len + vmslen) < vmspath_len)) { - d_spec[0] = '['; - d_spec[d_len - 1] = ']'; - if (d_len > 9) { - if (strEQ(&d_spec[1], "000000.")) { - d_spec += 7; - d_spec[7] = '['; - d_len -= 7; - if (d_len == 2) - d_len = 0; - } - } - - if (r_len > 0) { - /* Remove the redundant root */ - if (r_len > 0) { - /* remove the ][ */ - vmsptr--; - vmslen--; - d_spec++; - d_len--; - } - memcpy(vmsptr, d_spec, d_len); - vmsptr += d_len; - vmslen += d_len; - vmsptr[0] = '\0'; - } - } - break; - } - } - - PerlMem_free(esa); - PerlMem_free(trn); + /* Find the next slash */ + nextslash = strchr(unixptr,'/'); + + esa = (char *)PerlMem_malloc(vmspath_len); + if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM); + + trn = (char *)PerlMem_malloc(VMS_MAXRSS); + if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM); + + if (nextslash != NULL) { + + seg_len = nextslash - unixptr; + memcpy(esa, unixptr, seg_len); + esa[seg_len] = 0; + } + else { + seg_len = my_strlcpy(esa, unixptr, sizeof(esa)); + } + /* trnlnm(section) */ + islnm = vmstrnenv(esa, trn, 0, fildev, 0); + + if (islnm) { + /* Now fix up the directory */ + + /* Split up the path to find the components */ + sts = vms_split_path + (trn, + &v_spec, + &v_len, + &r_spec, + &r_len, + &d_spec, + &d_len, + &n_spec, + &n_len, + &e_spec, + &e_len, + &vs_spec, + &vs_len); + + while (sts == 0) { + + /* A logical name must be a directory or the full + specification. It is only a full specification if + it is the only component */ + if ((unixptr[seg_len] == '\0') || + (unixptr[seg_len+1] == '\0')) { + + /* Is a directory being required? */ + if (((n_len + e_len) != 0) && (dir_flag !=0)) { + /* Not a logical name */ + break; + } + + + if ((unixptr[seg_len] == '/') || (dir_flag != 0)) { + /* This must be a directory */ + if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) { + vmslen = my_strlcpy(vmsptr, esa, vmspath_len - 1); + vmsptr[vmslen] = ':'; + vmslen++; + vmsptr[vmslen] = '\0'; + return SS$_NORMAL; + } + } + + } + + + /* must be dev/directory - ignore version */ + if ((n_len + e_len) != 0) + break; + + /* transfer the volume */ + if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) { + memcpy(vmsptr, v_spec, v_len); + vmsptr += v_len; + vmsptr[0] = '\0'; + vmslen += v_len; + } + + /* unroot the rooted directory */ + if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) { + r_spec[0] = '['; + r_spec[r_len - 1] = ']'; + + /* This should not be there, but nothing is perfect */ + if (r_len > 9) { + if (strEQ(&r_spec[1], "000000.")) { + r_spec += 7; + r_spec[7] = '['; + r_len -= 7; + if (r_len == 2) + r_len = 0; + } + } + if (r_len > 0) { + memcpy(vmsptr, r_spec, r_len); + vmsptr += r_len; + vmslen += r_len; + vmsptr[0] = '\0'; + } + } + /* Bring over the directory. */ + if ((d_len > 0) && + ((d_len + vmslen) < vmspath_len)) { + d_spec[0] = '['; + d_spec[d_len - 1] = ']'; + if (d_len > 9) { + if (strEQ(&d_spec[1], "000000.")) { + d_spec += 7; + d_spec[7] = '['; + d_len -= 7; + if (d_len == 2) + d_len = 0; + } + } + + if (r_len > 0) { + /* Remove the redundant root */ + if (r_len > 0) { + /* remove the ][ */ + vmsptr--; + vmslen--; + d_spec++; + d_len--; + } + memcpy(vmsptr, d_spec, d_len); + vmsptr += d_len; + vmslen += d_len; + vmsptr[0] = '\0'; + } + } + break; + } + } + + PerlMem_free(esa); + PerlMem_free(trn); } if (lastslash > unixptr) { @@ -7939,54 +7939,54 @@ posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath, /* skip leading ./ */ dotdir_seen = 0; while ((unixptr[0] == '.') && (unixptr[1] == '/')) { - dotdir_seen = 1; - unixptr++; - unixptr++; + dotdir_seen = 1; + unixptr++; + unixptr++; } /* Are we still in a directory? */ if (unixptr <= lastslash) { - *vmsptr++ = '['; - vmslen = 1; - dir_start = 1; + *vmsptr++ = '['; + vmslen = 1; + dir_start = 1; - /* if not backing up, then it is relative forward. */ - if (!((*unixptr == '.') && (unixptr[1] == '.') && - ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) { - *vmsptr++ = '.'; - vmslen++; - dir_dot = 1; - } + /* if not backing up, then it is relative forward. */ + if (!((*unixptr == '.') && (unixptr[1] == '.') && + ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) { + *vmsptr++ = '.'; + vmslen++; + dir_dot = 1; + } } else { - if (dotdir_seen) { - /* Perl wants an empty directory here to tell the difference - * between a DCL command and a filename - */ - *vmsptr++ = '['; - *vmsptr++ = ']'; - vmslen = 2; - } + if (dotdir_seen) { + /* Perl wants an empty directory here to tell the difference + * between a DCL command and a filename + */ + *vmsptr++ = '['; + *vmsptr++ = ']'; + vmslen = 2; + } } } else { /* Handle two special files . and .. */ if (unixptr[0] == '.') { if (&unixptr[1] == unixend) { - *vmsptr++ = '['; - *vmsptr++ = ']'; - vmslen += 2; - *vmsptr++ = '\0'; - return SS$_NORMAL; - } + *vmsptr++ = '['; + *vmsptr++ = ']'; + vmslen += 2; + *vmsptr++ = '\0'; + return SS$_NORMAL; + } if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) { - *vmsptr++ = '['; - *vmsptr++ = '-'; - *vmsptr++ = ']'; - vmslen += 3; - *vmsptr++ = '\0'; - return SS$_NORMAL; - } + *vmsptr++ = '['; + *vmsptr++ = '-'; + *vmsptr++ = ']'; + vmslen += 3; + *vmsptr++ = '\0'; + return SS$_NORMAL; + } } } } @@ -8012,9 +8012,9 @@ posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath, seg_len = nextslash - &unixptr[1]; my_strlcpy(vmspath, unixptr, seg_len + 2); if (memEQs(vmspath, seg_len, "dev")) { - sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len); - if (sts == SS$_NORMAL) - return SS$_NORMAL; + sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len); + if (sts == SS$_NORMAL) + return SS$_NORMAL; } sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl); } @@ -8024,38 +8024,38 @@ posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath, sts = posix_root_to_vms(esa, vmspath_len, "/", NULL); if ($VMS_STATUS_SUCCESS(sts)) { - vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1); - vmsptr = vmspath + vmslen; - unixptr++; - if (unixptr < lastslash) { - char * rptr; - vmsptr--; - *vmsptr++ = '.'; - dir_start = 1; - dir_dot = 1; - if (vmslen > 7) { - rptr = vmsptr - 7; - if (strEQ(rptr,"000000.")) { - vmslen -= 7; - vmsptr -= 7; - vmsptr[1] = '\0'; - } /* removing 6 zeros */ - } /* vmslen < 7, no 6 zeros possible */ - } /* Not in a directory */ + vmslen = my_strlcpy(vmspath, esa, vmspath_len + 1); + vmsptr = vmspath + vmslen; + unixptr++; + if (unixptr < lastslash) { + char * rptr; + vmsptr--; + *vmsptr++ = '.'; + dir_start = 1; + dir_dot = 1; + if (vmslen > 7) { + rptr = vmsptr - 7; + if (strEQ(rptr,"000000.")) { + vmslen -= 7; + vmsptr -= 7; + vmsptr[1] = '\0'; + } /* removing 6 zeros */ + } /* vmslen < 7, no 6 zeros possible */ + } /* Not in a directory */ } /* Posix root found */ else { - /* No posix root, fall back to default directory */ - strcpy(vmspath, "SYS$DISK:["); - vmsptr = &vmspath[10]; - vmslen = 10; - if (unixptr > lastslash) { - *vmsptr = ']'; - vmsptr++; - vmslen++; - } - else { - dir_start = 1; - } + /* No posix root, fall back to default directory */ + strcpy(vmspath, "SYS$DISK:["); + vmsptr = &vmspath[10]; + vmslen = 10; + if (unixptr > lastslash) { + *vmsptr = ']'; + vmsptr++; + vmslen++; + } + else { + dir_start = 1; + } } } /* end of verified real path handling */ else { @@ -8075,53 +8075,53 @@ posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath, /* Now do we need to add the fake 6 zero directory to it? */ add_6zero = 1; if ((*lastslash == '/') && (nextslash < lastslash)) { - /* No there is another directory */ - add_6zero = 0; + /* No there is another directory */ + add_6zero = 0; } else { int trnend; - /* now we have foo:bar or foo:[000000]bar to decide from */ - islnm = vmstrnenv(vmspath, esa, 0, fildev, 0); + /* now we have foo:bar or foo:[000000]bar to decide from */ + islnm = vmstrnenv(vmspath, esa, 0, fildev, 0); if (!islnm && !DECC_POSIX_COMPLIANT_PATHNAMES) { - if (strEQ(vmspath, "bin")) { - /* bin => SYS$SYSTEM: */ - islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0); - } - else { - /* tmp => SYS$SCRATCH: */ - if (strEQ(vmspath, "tmp")) { - islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0); - } - } - } + if (strEQ(vmspath, "bin")) { + /* bin => SYS$SYSTEM: */ + islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0); + } + else { + /* tmp => SYS$SCRATCH: */ + if (strEQ(vmspath, "tmp")) { + islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0); + } + } + } trnend = islnm ? islnm - 1 : 0; - /* if this was a logical name, ']' or '>' must be present */ - /* if not a logical name, then assume a device and hope. */ - islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0; + /* if this was a logical name, ']' or '>' must be present */ + /* if not a logical name, then assume a device and hope. */ + islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0; - /* if log name and trailing '.' then rooted - treat as device */ - add_6zero = islnm ? (esa[trnend-1] == '.') : 0; + /* if log name and trailing '.' then rooted - treat as device */ + add_6zero = islnm ? (esa[trnend-1] == '.') : 0; - /* Fix me, if not a logical name, a device lookup should be + /* Fix me, if not a logical name, a device lookup should be * done to see if the device is file structured. If the device * is not file structured, the 6 zeros should not be put on. * * As it is, perl is occasionally looking for dev:[000000]tty. - * which looks a little strange. - * - * Not that easy to detect as "/dev" may be file structured with - * special device files. + * which looks a little strange. + * + * Not that easy to detect as "/dev" may be file structured with + * special device files. */ - if (!islnm && (add_6zero == 0) && (*nextslash == '/') && - (&nextslash[1] == unixend)) { - /* No real directory present */ - add_6zero = 1; - } + if (!islnm && (add_6zero == 0) && (*nextslash == '/') && + (&nextslash[1] == unixend)) { + /* No real directory present */ + add_6zero = 1; + } } /* Put the device delimiter on */ @@ -8132,22 +8132,22 @@ posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath, /* Start directory if needed */ if (!islnm || add_6zero) { - *vmsptr++ = '['; - vmslen++; - dir_start = 1; + *vmsptr++ = '['; + vmslen++; + dir_start = 1; } /* add fake 000000] if needed */ if (add_6zero) { - *vmsptr++ = '0'; - *vmsptr++ = '0'; - *vmsptr++ = '0'; - *vmsptr++ = '0'; - *vmsptr++ = '0'; - *vmsptr++ = '0'; - *vmsptr++ = ']'; - vmslen += 7; - dir_start = 0; + *vmsptr++ = '0'; + *vmsptr++ = '0'; + *vmsptr++ = '0'; + *vmsptr++ = '0'; + *vmsptr++ = '0'; + *vmsptr++ = '0'; + *vmsptr++ = ']'; + vmslen += 7; + dir_start = 0; } } /* non-POSIX translation */ @@ -8165,109 +8165,109 @@ posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath, /* First characters in a directory are handled special */ while ((*unixptr == '/') || - ((*unixptr == '.') && - ((unixptr[1]=='.') || (unixptr[1]=='/') || - (&unixptr[1]==unixend)))) { + ((*unixptr == '.') && + ((unixptr[1]=='.') || (unixptr[1]=='/') || + (&unixptr[1]==unixend)))) { int loop_flag; - loop_flag = 0; + loop_flag = 0; /* Skip redundant / in specification */ while ((*unixptr == '/') && (dir_start != 0)) { - loop_flag = 1; - unixptr++; - if (unixptr == lastslash) - break; - } - if (unixptr == lastslash) - break; + loop_flag = 1; + unixptr++; + if (unixptr == lastslash) + break; + } + if (unixptr == lastslash) + break; /* Skip redundant ./ characters */ - while ((*unixptr == '.') && - ((unixptr[1] == '/')||(&unixptr[1] == unixend))) { - loop_flag = 1; - unixptr++; - if (unixptr == lastslash) - break; - if (*unixptr == '/') - unixptr++; - } - if (unixptr == lastslash) - break; - - /* Skip redundant ../ characters */ - while ((*unixptr == '.') && (unixptr[1] == '.') && - ((unixptr[2] == '/') || (&unixptr[2] == unixend))) { - /* Set the backing up flag */ - loop_flag = 1; - dir_dot = 0; - dash_flag = 1; - *vmsptr++ = '-'; - vmslen++; - unixptr++; /* first . */ - unixptr++; /* second . */ - if (unixptr == lastslash) - break; - if (*unixptr == '/') /* The slash */ - unixptr++; - } - if (unixptr == lastslash) - break; - - /* To do: Perl expects /.../ to be translated to [...] on VMS */ - /* Not needed when VMS is pretending to be UNIX. */ - - /* Is this loop stuck because of too many dots? */ - if (loop_flag == 0) { - /* Exit the loop and pass the rest through */ - break; - } + while ((*unixptr == '.') && + ((unixptr[1] == '/')||(&unixptr[1] == unixend))) { + loop_flag = 1; + unixptr++; + if (unixptr == lastslash) + break; + if (*unixptr == '/') + unixptr++; + } + if (unixptr == lastslash) + break; + + /* Skip redundant ../ characters */ + while ((*unixptr == '.') && (unixptr[1] == '.') && + ((unixptr[2] == '/') || (&unixptr[2] == unixend))) { + /* Set the backing up flag */ + loop_flag = 1; + dir_dot = 0; + dash_flag = 1; + *vmsptr++ = '-'; + vmslen++; + unixptr++; /* first . */ + unixptr++; /* second . */ + if (unixptr == lastslash) + break; + if (*unixptr == '/') /* The slash */ + unixptr++; + } + if (unixptr == lastslash) + break; + + /* To do: Perl expects /.../ to be translated to [...] on VMS */ + /* Not needed when VMS is pretending to be UNIX. */ + + /* Is this loop stuck because of too many dots? */ + if (loop_flag == 0) { + /* Exit the loop and pass the rest through */ + break; + } } /* Are we done with directories yet? */ if (unixptr >= lastslash) { - /* Watch out for trailing dots */ - if (dir_dot != 0) { - vmslen --; - vmsptr--; - } - *vmsptr++ = ']'; - vmslen++; - dash_flag = 0; - dir_start = 0; - if (*unixptr == '/') - unixptr++; + /* Watch out for trailing dots */ + if (dir_dot != 0) { + vmslen --; + vmsptr--; + } + *vmsptr++ = ']'; + vmslen++; + dash_flag = 0; + dir_start = 0; + if (*unixptr == '/') + unixptr++; } else { - /* Have we stopped backing up? */ - if (dash_flag) { - *vmsptr++ = '.'; - vmslen++; - dash_flag = 0; - /* dir_start continues to be = 1 */ - } - if (*unixptr == '-') { - *vmsptr++ = '^'; - *vmsptr++ = *unixptr++; - vmslen += 2; - dir_start = 0; - - /* Now are we done with directories yet? */ - if (unixptr >= lastslash) { - - /* Watch out for trailing dots */ - if (dir_dot != 0) { - vmslen --; - vmsptr--; - } - - *vmsptr++ = ']'; - vmslen++; - dash_flag = 0; - dir_start = 0; - } - } + /* Have we stopped backing up? */ + if (dash_flag) { + *vmsptr++ = '.'; + vmslen++; + dash_flag = 0; + /* dir_start continues to be = 1 */ + } + if (*unixptr == '-') { + *vmsptr++ = '^'; + *vmsptr++ = *unixptr++; + vmslen += 2; + dir_start = 0; + + /* Now are we done with directories yet? */ + if (unixptr >= lastslash) { + + /* Watch out for trailing dots */ + if (dir_dot != 0) { + vmslen --; + vmsptr--; + } + + *vmsptr++ = ']'; + vmslen++; + dash_flag = 0; + dir_start = 0; + } + } } } @@ -8281,72 +8281,72 @@ posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath, switch(*unixptr) { case '/': - /* remove multiple / */ - while (unixptr[1] == '/') { - unixptr++; - } - if (unixptr == lastslash) { - /* Watch out for trailing dots */ - if (dir_dot != 0) { - vmslen --; - vmsptr--; - } - *vmsptr++ = ']'; - } - else { - dir_start = 1; - *vmsptr++ = '.'; - dir_dot = 1; - - /* To do: Perl expects /.../ to be translated to [...] on VMS */ - /* Not needed when VMS is pretending to be UNIX. */ - - } - dash_flag = 0; - if (unixptr != unixend) - unixptr++; - vmslen++; - break; + /* remove multiple / */ + while (unixptr[1] == '/') { + unixptr++; + } + if (unixptr == lastslash) { + /* Watch out for trailing dots */ + if (dir_dot != 0) { + vmslen --; + vmsptr--; + } + *vmsptr++ = ']'; + } + else { + dir_start = 1; + *vmsptr++ = '.'; + dir_dot = 1; + + /* To do: Perl expects /.../ to be translated to [...] on VMS */ + /* Not needed when VMS is pretending to be UNIX. */ + + } + dash_flag = 0; + if (unixptr != unixend) + unixptr++; + vmslen++; + break; case '.': - if ((unixptr < lastdot) || (unixptr < lastslash) || - (&unixptr[1] == unixend)) { - *vmsptr++ = '^'; - *vmsptr++ = '.'; - vmslen += 2; - unixptr++; - - /* trailing dot ==> '^..' on VMS */ - if (unixptr == unixend) { - *vmsptr++ = '.'; - vmslen++; - unixptr++; - } - break; - } - - *vmsptr++ = *unixptr++; - vmslen ++; - break; + if ((unixptr < lastdot) || (unixptr < lastslash) || + (&unixptr[1] == unixend)) { + *vmsptr++ = '^'; + *vmsptr++ = '.'; + vmslen += 2; + unixptr++; + + /* trailing dot ==> '^..' on VMS */ + if (unixptr == unixend) { + *vmsptr++ = '.'; + vmslen++; + unixptr++; + } + break; + } + + *vmsptr++ = *unixptr++; + vmslen ++; + break; case '"': - if (quoted && (&unixptr[1] == unixend)) { - unixptr++; - break; - } - in_cnt = copy_expand_unix_filename_escape - (vmsptr, unixptr, &out_cnt, utf8_fl); - vmsptr += out_cnt; - unixptr += in_cnt; - break; + if (quoted && (&unixptr[1] == unixend)) { + unixptr++; + break; + } + in_cnt = copy_expand_unix_filename_escape + (vmsptr, unixptr, &out_cnt, utf8_fl); + vmsptr += out_cnt; + unixptr += in_cnt; + break; case ';': case '\\': case '?': case ' ': default: - in_cnt = copy_expand_unix_filename_escape - (vmsptr, unixptr, &out_cnt, utf8_fl); - vmsptr += out_cnt; - unixptr += in_cnt; - break; + in_cnt = copy_expand_unix_filename_escape + (vmsptr, unixptr, &out_cnt, utf8_fl); + vmsptr += out_cnt; + unixptr += in_cnt; + break; } } @@ -8360,12 +8360,12 @@ posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath, /* directories do not end in a dot bracket */ if (*vmsptr2 == '.') { - vmsptr2--; + vmsptr2--; - /* ^. is allowed */ + /* ^. is allowed */ if (*vmsptr2 != '^') { - vmsptr--; /* back up over the dot */ - } + vmsptr--; /* back up over the dot */ + } } *vmsptr++ = ']'; } @@ -8375,9 +8375,9 @@ posix_to_vmsspec_hardway(char *vmspath, int vmspath_len, const char *unixpath, /* Add a trailing dot if a file with no extension */ vmsptr2 = vmsptr - 1; if ((vmslen > 1) && - (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') && - (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) { - *vmsptr++ = '.'; + (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') && + (*vmsptr2 != ')') && (*lastdot != '.') && (*vmsptr2 != ':')) { + *vmsptr++ = '.'; vmslen++; } } @@ -8436,15 +8436,15 @@ int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag) if (path[1] == '\0') { strcpy(rslt,"[]"); if (utf8_flag != NULL) - *utf8_flag = 0; + *utf8_flag = 0; return rslt; } else { if (path[1] == '.' && path[2] == '\0') { - strcpy(rslt,"[-]"); - if (utf8_flag != NULL) - *utf8_flag = 0; - return rslt; + strcpy(rslt,"[-]"); + if (utf8_flag != NULL) + *utf8_flag = 0; + return rslt; } } } @@ -8463,18 +8463,18 @@ int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag) /* This is really the only way to see if this is already in VMS format */ sts = vms_split_path (path, - &v_spec, - &v_len, - &r_spec, - &r_len, - &d_spec, - &d_len, - &n_spec, - &n_len, - &e_spec, - &e_len, - &vs_spec, - &vs_len); + &v_spec, + &v_len, + &r_spec, + &r_len, + &d_spec, + &d_len, + &n_spec, + &n_len, + &e_spec, + &e_len, + &vs_spec, + &vs_len); if (sts == 0) { /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath() replacement, because the above parse just took care of most of @@ -8489,7 +8489,7 @@ int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag) /* If VMS punctuation was found, it is already VMS format */ if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) { if (utf8_flag != NULL) - *utf8_flag = 0; + *utf8_flag = 0; my_strlcpy(rslt, path, VMS_MAXRSS); if (vms_debug_fileify) { fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt); @@ -8553,13 +8553,13 @@ int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag) while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */ if (!*(cp2+1)) { if (DECC_DISABLE_POSIX_ROOT) { - strcpy(rslt,"sys$disk:[000000]"); + strcpy(rslt,"sys$disk:[000000]"); } else { - strcpy(rslt,"sys$posix_root:[000000]"); + strcpy(rslt,"sys$posix_root:[000000]"); } if (utf8_flag != NULL) - *utf8_flag = 0; + *utf8_flag = 0; if (vms_debug_fileify) { fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt); } @@ -8574,35 +8574,35 @@ int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag) /* DECC special handling */ if (!islnm) { if (strEQ(rslt,"bin")) { - strcpy(rslt,"sys$system"); - cp1 = rslt + 10; - *cp1 = 0; - islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1); + strcpy(rslt,"sys$system"); + cp1 = rslt + 10; + *cp1 = 0; + islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1); } else if (strEQ(rslt,"tmp")) { - strcpy(rslt,"sys$scratch"); - cp1 = rslt + 11; - *cp1 = 0; - islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1); + strcpy(rslt,"sys$scratch"); + cp1 = rslt + 11; + *cp1 = 0; + islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1); } else if (!DECC_DISABLE_POSIX_ROOT) { strcpy(rslt, "sys$posix_root"); - cp1 = rslt + 14; - *cp1 = 0; - cp2 = path; + cp1 = rslt + 14; + *cp1 = 0; + cp2 = path; while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */ - islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1); + islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1); } else if (strEQ(rslt,"dev")) { - if (strBEGINs(cp2,"/null")) { - if ((cp2[5] == 0) || (cp2[5] == '/')) { - strcpy(rslt,"NLA0"); - cp1 = rslt + 4; - *cp1 = 0; - cp2 = cp2 + 5; - islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1); - } - } + if (strBEGINs(cp2,"/null")) { + if ((cp2[5] == 0) || (cp2[5] == '/')) { + strcpy(rslt,"NLA0"); + cp1 = rslt + 4; + *cp1 = 0; + cp2 = cp2 + 5; + islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1); + } + } } } @@ -8621,16 +8621,16 @@ int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag) if (cp2 != dirend) { my_strlcpy(rslt, trndev, VMS_MAXRSS); cp1 = rslt + trnend; - if (*cp2 != 0) { + if (*cp2 != 0) { *(cp1++) = '.'; cp2++; } } else { - if (DECC_DISABLE_POSIX_ROOT) { - *(cp1++) = ':'; - hasdir = 0; - } + if (DECC_DISABLE_POSIX_ROOT) { + *(cp1++) = ':'; + hasdir = 0; + } } } PerlMem_free(trndev); @@ -8653,8 +8653,8 @@ int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag) cp2 += 4; } else if ((cp2 != lastdot) || (lastdot < dirend)) { - /* Escape the extra dots in EFS file specifications */ - *(cp1++) = '^'; + /* Escape the extra dots in EFS file specifications */ + *(cp1++) = '^'; } if (cp2 > dirend) cp2 = dirend; } @@ -8690,26 +8690,26 @@ int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag) } else { if (DECC_EFS_CHARSET == 0) { - if (cp1 > rslt && *(cp1-1) == '^') - cp1--; /* remove the escape, if any */ - *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */ - } - else { - VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS); - } + if (cp1 > rslt && *(cp1-1) == '^') + cp1--; /* remove the escape, if any */ + *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */ + } + else { + VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS); + } } } else { if (!infront && cp1 > rslt && *(cp1-1) == '-') *(cp1++) = '.'; if (*cp2 == '.') { if (DECC_EFS_CHARSET == 0) { - if (cp1 > rslt && *(cp1-1) == '^') - cp1--; /* remove the escape, if any */ - *(cp1++) = '_'; - } - else { - VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS); - } + if (cp1 > rslt && *(cp1-1) == '^') + cp1--; /* remove the escape, if any */ + *(cp1++) = '_'; + } + else { + VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS); + } } else { int out_cnt; @@ -8730,66 +8730,66 @@ int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag) switch(*cp2) { case '?': if (DECC_EFS_CHARSET == 0) - *(cp1++) = '%'; - else - *(cp1++) = '?'; - cp2++; - break; + *(cp1++) = '%'; + else + *(cp1++) = '?'; + cp2++; + break; case ' ': - if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */ - *(cp1)++ = '^'; - *(cp1)++ = '_'; - cp2++; - break; + if (cp2 >= path && (cp2 == path || *(cp2-1) != '^')) /* not previously escaped */ + *(cp1)++ = '^'; + *(cp1)++ = '_'; + cp2++; + break; case '.': - if (((cp2 < lastdot) || (cp2[1] == '\0')) && - DECC_READDIR_DROPDOTNOTYPE) { - VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS); - cp2++; - - /* trailing dot ==> '^..' on VMS */ - if (*cp2 == '\0') { - *(cp1++) = '.'; - no_type_seen = 0; - } - } - else { - *(cp1++) = *(cp2++); - no_type_seen = 0; - } - break; + if (((cp2 < lastdot) || (cp2[1] == '\0')) && + DECC_READDIR_DROPDOTNOTYPE) { + VMSEFS_DOT_WITH_ESCAPE(cp1, rslt, VMS_MAXRSS); + cp2++; + + /* trailing dot ==> '^..' on VMS */ + if (*cp2 == '\0') { + *(cp1++) = '.'; + no_type_seen = 0; + } + } + else { + *(cp1++) = *(cp2++); + no_type_seen = 0; + } + break; case '$': - /* This could be a macro to be passed through */ - *(cp1++) = *(cp2++); - if (*cp2 == '(') { - const char * save_cp2; - char * save_cp1; - int is_macro; - - /* paranoid check */ - save_cp2 = cp2; - save_cp1 = cp1; - is_macro = 0; - - /* Test through */ - *(cp1++) = *(cp2++); - if (isALPHA_L1(*cp2) || (*cp2 == '.') || (*cp2 == '_')) { - *(cp1++) = *(cp2++); - while (isALPHA_L1(*cp2) || (*cp2 == '.') || (*cp2 == '_')) { - *(cp1++) = *(cp2++); - } - if (*cp2 == ')') { - *(cp1++) = *(cp2++); - is_macro = 1; - } - } - if (is_macro == 0) { - /* Not really a macro - never mind */ - cp2 = save_cp2; - cp1 = save_cp1; - } - } - break; + /* This could be a macro to be passed through */ + *(cp1++) = *(cp2++); + if (*cp2 == '(') { + const char * save_cp2; + char * save_cp1; + int is_macro; + + /* paranoid check */ + save_cp2 = cp2; + save_cp1 = cp1; + is_macro = 0; + + /* Test through */ + *(cp1++) = *(cp2++); + if (isALPHA_L1(*cp2) || (*cp2 == '.') || (*cp2 == '_')) { + *(cp1++) = *(cp2++); + while (isALPHA_L1(*cp2) || (*cp2 == '.') || (*cp2 == '_')) { + *(cp1++) = *(cp2++); + } + if (*cp2 == ')') { + *(cp1++) = *(cp2++); + is_macro = 1; + } + } + if (is_macro == 0) { + /* Not really a macro - never mind */ + cp2 = save_cp2; + cp1 = save_cp1; + } + } + break; case '\"': case '`': case '!': @@ -8800,8 +8800,8 @@ int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag) * already something we escape. */ if (memCHRs("\"`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) { - *(cp1++) = *(cp2++); - break; + *(cp1++) = *(cp2++); + break; } /* But otherwise fall through and escape it. */ case '&': @@ -8820,27 +8820,27 @@ int_tovmsspec(const char *path, char *rslt, int dir_flag, int * utf8_flag) case '|': case '<': case '>': - if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */ - *(cp1++) = '^'; - *(cp1++) = *(cp2++); - break; + if (cp2 >= path && *(cp2-1) != '^') /* not previously escaped */ + *(cp1++) = '^'; + *(cp1++) = *(cp2++); + break; case ';': /* If it doesn't look like the beginning of a version number, * or we've been promised there are no version numbers, then * escape it. */ - if (DECC_FILENAME_UNIX_NO_VERSION) { - *(cp1++) = '^'; - } - else { - size_t all_nums = strspn(cp2+1, "0123456789"); - if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0') - *(cp1++) = '^'; - } - *(cp1++) = *(cp2++); - break; + if (DECC_FILENAME_UNIX_NO_VERSION) { + *(cp1++) = '^'; + } + else { + size_t all_nums = strspn(cp2+1, "0123456789"); + if (all_nums > 5 || *(cp2 + all_nums + 1) != '\0') + *(cp1++) = '^'; + } + *(cp1++) = *(cp2++); + break; default: - *(cp1++) = *(cp2++); + *(cp1++) = *(cp2++); } } if ((no_type_seen == 1) && DECC_READDIR_DROPDOTNOTYPE) { @@ -9129,14 +9129,14 @@ struct list_item }; static void add_item(struct list_item **head, - struct list_item **tail, - char *value, - int *count); + struct list_item **tail, + char *value, + int *count); static void mp_expand_wild_cards(pTHX_ char *item, - struct list_item **head, - struct list_item **tail, - int *count); + struct list_item **head, + struct list_item **tail, + int *count); static int background_process(pTHX_ int argc, char **argv); @@ -9190,104 +9190,104 @@ mp_getredirection(pTHX_ int *ac, char ***av) if (strEQ(ap, "&")) exit(background_process(aTHX_ --argc, argv)); if (*ap && '&' == ap[strlen(ap)-1]) - { - ap[strlen(ap)-1] = '\0'; + { + ap[strlen(ap)-1] = '\0'; exit(background_process(aTHX_ argc, argv)); - } + } /* * Now we handle the general redirection cases that involve '>', '>>', * '<', and pipes '|'. */ for (j = 0; j < argc; ++j) - { - if (strEQ(argv[j], "<")) - { - if (j+1 >= argc) - { - fprintf(stderr,"No input file after < on command line"); - exit(LIB$_WRONUMARG); - } - in = argv[++j]; - continue; - } - if ('<' == *(ap = argv[j])) - { - in = 1 + ap; - continue; - } - if (strEQ(ap, ">")) - { - if (j+1 >= argc) - { - fprintf(stderr,"No output file after > on command line"); - exit(LIB$_WRONUMARG); - } - out = argv[++j]; - continue; - } - if ('>' == *ap) - { - if ('>' == ap[1]) - { - outmode = "a"; - if ('\0' == ap[2]) - out = argv[++j]; - else - out = 2 + ap; - } - else - out = 1 + ap; - if (j >= argc) - { - fprintf(stderr,"No output file after > or >> on command line"); - exit(LIB$_WRONUMARG); - } - continue; - } - if (('2' == *ap) && ('>' == ap[1])) - { - if ('>' == ap[2]) - { - errmode = "a"; - if ('\0' == ap[3]) - err = argv[++j]; - else - err = 3 + ap; - } - else - if ('\0' == ap[2]) - err = argv[++j]; - else - err = 2 + ap; - if (j >= argc) - { - fprintf(stderr,"No output file after 2> or 2>> on command line"); - exit(LIB$_WRONUMARG); - } - continue; - } - if (strEQ(argv[j], "|")) - { - if (j+1 >= argc) - { - fprintf(stderr,"No command into which to pipe on command line"); - exit(LIB$_WRONUMARG); - } - cmargc = argc-(j+1); - cmargv = &argv[j+1]; - argc = j; - continue; - } - if ('|' == *(ap = argv[j])) - { - ++argv[j]; - cmargc = argc-j; - cmargv = &argv[j]; - argc = j; - continue; - } - expand_wild_cards(ap, &list_head, &list_tail, &item_count); - } + { + if (strEQ(argv[j], "<")) + { + if (j+1 >= argc) + { + fprintf(stderr,"No input file after < on command line"); + exit(LIB$_WRONUMARG); + } + in = argv[++j]; + continue; + } + if ('<' == *(ap = argv[j])) + { + in = 1 + ap; + continue; + } + if (strEQ(ap, ">")) + { + if (j+1 >= argc) + { + fprintf(stderr,"No output file after > on command line"); + exit(LIB$_WRONUMARG); + } + out = argv[++j]; + continue; + } + if ('>' == *ap) + { + if ('>' == ap[1]) + { + outmode = "a"; + if ('\0' == ap[2]) + out = argv[++j]; + else + out = 2 + ap; + } + else + out = 1 + ap; + if (j >= argc) + { + fprintf(stderr,"No output file after > or >> on command line"); + exit(LIB$_WRONUMARG); + } + continue; + } + if (('2' == *ap) && ('>' == ap[1])) + { + if ('>' == ap[2]) + { + errmode = "a"; + if ('\0' == ap[3]) + err = argv[++j]; + else + err = 3 + ap; + } + else + if ('\0' == ap[2]) + err = argv[++j]; + else + err = 2 + ap; + if (j >= argc) + { + fprintf(stderr,"No output file after 2> or 2>> on command line"); + exit(LIB$_WRONUMARG); + } + continue; + } + if (strEQ(argv[j], "|")) + { + if (j+1 >= argc) + { + fprintf(stderr,"No command into which to pipe on command line"); + exit(LIB$_WRONUMARG); + } + cmargc = argc-(j+1); + cmargv = &argv[j+1]; + argc = j; + continue; + } + if ('|' == *(ap = argv[j])) + { + ++argv[j]; + cmargc = argc-j; + cmargv = &argv[j]; + argc = j; + continue; + } + expand_wild_cards(ap, &list_head, &list_tail, &item_count); + } /* * Allocate and fill in the new argument vector, Some Unix's terminate * the list with an extra null pointer. @@ -9296,84 +9296,84 @@ mp_getredirection(pTHX_ int *ac, char ***av) if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM); *av = argv; for (j = 0; j < item_count; ++j, list_head = list_head->next) - argv[j] = list_head->value; + argv[j] = list_head->value; *ac = item_count; if (cmargv != NULL) - { - if (out != NULL) - { - fprintf(stderr,"'|' and '>' may not both be specified on command line"); - exit(LIB$_INVARGORD); - } - pipe_and_fork(aTHX_ cmargv); - } - + { + if (out != NULL) + { + fprintf(stderr,"'|' and '>' may not both be specified on command line"); + exit(LIB$_INVARGORD); + } + pipe_and_fork(aTHX_ cmargv); + } + /* Check for input from a pipe (mailbox) */ if (in == NULL && 1 == isapipe(0)) - { - char mbxname[L_tmpnam]; - long int bufsize; - long int dvi_item = DVI$_DEVBUFSIZ; - $DESCRIPTOR(mbxnam, ""); - $DESCRIPTOR(mbxdevnam, ""); - - /* Input from a pipe, reopen it in binary mode to disable */ - /* carriage control processing. */ - - fgetname(stdin, mbxname, 1); - mbxnam.dsc$a_pointer = mbxname; - mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); - lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0); - mbxdevnam.dsc$a_pointer = mbxname; - mbxdevnam.dsc$w_length = sizeof(mbxname); - dvi_item = DVI$_DEVNAM; - lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length); - mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0'; - set_errno(0); - set_vaxc_errno(1); - freopen(mbxname, "rb", stdin); - if (errno != 0) - { - fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname); - exit(vaxc$errno); - } - } + { + char mbxname[L_tmpnam]; + long int bufsize; + long int dvi_item = DVI$_DEVBUFSIZ; + $DESCRIPTOR(mbxnam, ""); + $DESCRIPTOR(mbxdevnam, ""); + + /* Input from a pipe, reopen it in binary mode to disable */ + /* carriage control processing. */ + + fgetname(stdin, mbxname, 1); + mbxnam.dsc$a_pointer = mbxname; + mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer); + lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0); + mbxdevnam.dsc$a_pointer = mbxname; + mbxdevnam.dsc$w_length = sizeof(mbxname); + dvi_item = DVI$_DEVNAM; + lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length); + mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0'; + set_errno(0); + set_vaxc_errno(1); + freopen(mbxname, "rb", stdin); + if (errno != 0) + { + fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname); + exit(vaxc$errno); + } + } if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2"))) - { - fprintf(stderr,"Can't open input file %s as stdin",in); - exit(vaxc$errno); - } + { + fprintf(stderr,"Can't open input file %s as stdin",in); + exit(vaxc$errno); + } if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2"))) - { - fprintf(stderr,"Can't open output file %s as stdout",out); - exit(vaxc$errno); - } - if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out); + { + fprintf(stderr,"Can't open output file %s as stdout",out); + exit(vaxc$errno); + } + if (out != NULL) vmssetuserlnm("SYS$OUTPUT", out); if (err != NULL) { if (strEQ(err, "&1")) { dup2(fileno(stdout), fileno(stderr)); vmssetuserlnm("SYS$ERROR", "SYS$OUTPUT"); } else { - FILE *tmperr; - if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2"))) - { - fprintf(stderr,"Can't open error file %s as stderr",err); - exit(vaxc$errno); - } - fclose(tmperr); + FILE *tmperr; + if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2"))) + { + fprintf(stderr,"Can't open error file %s as stderr",err); + exit(vaxc$errno); + } + fclose(tmperr); if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2")) - { - exit(vaxc$errno); - } - vmssetuserlnm("SYS$ERROR", err); - } + { + exit(vaxc$errno); + } + vmssetuserlnm("SYS$ERROR", err); + } } #ifdef ARGPROC_DEBUG PerlIO_printf(Perl_debug_log, "Arglist:\n"); for (j = 0; j < *ac; ++j) - PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]); + PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]); #endif /* Clear errors we may have hit expanding wildcards, so they don't show up in Perl's $! later */ @@ -9385,16 +9385,16 @@ static void add_item(struct list_item **head, struct list_item **tail, char *value, int *count) { if (*head == 0) - { - *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item)); - if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM); - *tail = *head; - } + { + *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item)); + if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM); + *tail = *head; + } else { - (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item)); - if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM); - *tail = (*tail)->next; - } + (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item)); + if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM); + *tail = (*tail)->next; + } (*tail)->value = value; ++(*count); } @@ -9424,14 +9424,14 @@ mp_expand_wild_cards(pTHX_ char *item, struct list_item **head, #endif for (cp = item; *cp; cp++) { - if (*cp == '*' || *cp == '%' || isSPACE_L1(*cp)) break; - if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break; + if (*cp == '*' || *cp == '%' || isSPACE_L1(*cp)) break; + if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break; } if (!*cp || isSPACE_L1(*cp)) - { - add_item(head, tail, item, count); - return; - } + { + add_item(head, tail, item, count); + return; + } else { /* "double quoted" wild card expressions pass as is */ @@ -9467,58 +9467,58 @@ mp_expand_wild_cards(pTHX_ char *item, struct list_item **head, had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<')); while ($VMS_STATUS_SUCCESS(sts = lib$find_file - (&filespec, &resultspec, &context, - &defaultspec, 0, &rms_sts, &lff_flags))) - { - char *string; - char *c; + (&filespec, &resultspec, &context, + &defaultspec, 0, &rms_sts, &lff_flags))) + { + char *string; + char *c; - string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1); + string = (char *)PerlMem_malloc(resultspec.dsc$w_length+1); if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM); - my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1); - if (NULL == had_version) - *(strrchr(string, ';')) = '\0'; - if ((!had_directory) && (had_device == NULL)) - { - if (NULL == (devdir = strrchr(string, ']'))) - devdir = strrchr(string, '>'); - my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1); - } - /* - * Be consistent with what the C RTL has already done to the rest of - * the argv items and lowercase all of these names. - */ - if (!DECC_EFS_CASE_PRESERVE) { - for (c = string; *c; ++c) - if (isupper(*c)) - *c = toLOWER_L1(*c); - } - if (isunix) trim_unixpath(string,item,1); - add_item(head, tail, string, count); - ++expcount; + my_strlcpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length+1); + if (NULL == had_version) + *(strrchr(string, ';')) = '\0'; + if ((!had_directory) && (had_device == NULL)) + { + if (NULL == (devdir = strrchr(string, ']'))) + devdir = strrchr(string, '>'); + my_strlcpy(string, devdir + 1, resultspec.dsc$w_length+1); + } + /* + * Be consistent with what the C RTL has already done to the rest of + * the argv items and lowercase all of these names. + */ + if (!DECC_EFS_CASE_PRESERVE) { + for (c = string; *c; ++c) + if (isupper(*c)) + *c = toLOWER_L1(*c); + } + if (isunix) trim_unixpath(string,item,1); + add_item(head, tail, string, count); + ++expcount; } PerlMem_free(vmsspec); if (sts != RMS$_NMF) - { - set_vaxc_errno(sts); - switch (sts) - { - case RMS$_FNF: case RMS$_DNF: - set_errno(ENOENT); break; - case RMS$_DIR: - set_errno(ENOTDIR); break; - case RMS$_DEV: - set_errno(ENODEV); break; - case RMS$_FNM: case RMS$_SYN: - set_errno(EINVAL); break; - case RMS$_PRV: - set_errno(EACCES); break; - default: - _ckvmssts_noperl(sts); - } - } + { + set_vaxc_errno(sts); + switch (sts) + { + case RMS$_FNF: case RMS$_DNF: + set_errno(ENOENT); break; + case RMS$_DIR: + set_errno(ENOTDIR); break; + case RMS$_DEV: + set_errno(ENODEV); break; + case RMS$_FNM: case RMS$_SYN: + set_errno(EINVAL); break; + case RMS$_PRV: + set_errno(EACCES); break; + default: + _ckvmssts_noperl(sts); + } + } if (expcount == 0) - add_item(head, tail, item, count); + add_item(head, tail, item, count); _ckvmssts_noperl(lib$sfree1_dd(&resultspec)); _ckvmssts_noperl(lib$find_file_end(&context)); } @@ -9557,12 +9557,12 @@ pipe_and_fork(pTHX_ char **cmargv) *p++ = '"'; l++; } - } + } } else { if ((quote||tquote) && *q == '"') { *p++ = '"'; l++; - } + } *p++ = *q++; l++; } @@ -9591,20 +9591,20 @@ background_process(pTHX_ int argc, char **argv) len = my_strlcat(command, argv[0], sizeof(command)); while (--argc && (len < MAX_DCL_SYMBOL)) - { - my_strlcat(command, " \"", sizeof(command)); - my_strlcat(command, *(++argv), sizeof(command)); - len = my_strlcat(command, "\"", sizeof(command)); - } + { + my_strlcat(command, " \"", sizeof(command)); + my_strlcat(command, *(++argv), sizeof(command)); + len = my_strlcat(command, "\"", sizeof(command)); + } value.dsc$a_pointer = command; value.dsc$w_length = strlen(value.dsc$a_pointer); _ckvmssts_noperl(lib$set_symbol(&cmd, &value)); retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid); if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */ - _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid)); + _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid)); } else { - _ckvmssts_noperl(retsts); + _ckvmssts_noperl(retsts); } #ifdef ARGPROC_DEBUG PerlIO_printf(Perl_debug_log, "%s\n", command); @@ -9711,11 +9711,11 @@ vms_image_init(int *argcp, char ***argvp) if (ulen > 7) { zeros = strstr(argvp[0][0], "/000000/"); if (zeros != NULL) { - int mlen; - mlen = ulen - (zeros - argvp[0][0]) - 7; - memmove(zeros, &zeros[7], mlen); - ulen = ulen - 7; - argvp[0][0][ulen] = '\0'; + int mlen; + mlen = ulen - (zeros - argvp[0][0]) - 7; + memmove(zeros, &zeros[7], mlen); + ulen = ulen - 7; + argvp[0][0][ulen] = '\0'; } } /* It also may have a trailing dot that needs to be removed otherwise @@ -9766,7 +9766,7 @@ vms_image_init(int *argcp, char ***argvp) tabidx++) { if (!tabidx) { tabvec = (struct dsc$descriptor_s **) - PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *)); + PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *)); if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM); } else if (tabidx >= tabct) { @@ -9827,7 +9827,7 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) if (strpbrk(wildspec,"]>:") != NULL) { if (int_tounixspec(wildspec, unixwild, NULL) == NULL) { PerlMem_free(unixwild); - return 0; + return 0; } } else { @@ -9839,7 +9839,7 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) if (int_tounixspec(fspec, unixified, NULL) == NULL) { PerlMem_free(unixwild); PerlMem_free(unixified); - return 0; + return 0; } else base = unixified; /* reslen != 0 ==> we had to unixify resultant filespec, so we must @@ -9853,12 +9853,12 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) PerlMem_free(unixwild); if (base == fspec) { PerlMem_free(unixified); - return 1; + return 1; } tmplen = strlen(unixified); if (tmplen > reslen) { PerlMem_free(unixified); - return 0; /* not enough space */ + return 0; /* not enough space */ } /* Copy unixified resultant, including trailing NUL */ memmove(fspec,unixified,tmplen+1); @@ -9899,22 +9899,22 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) * could match template). */ if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) { - PerlMem_free(tpl); - PerlMem_free(unixified); - PerlMem_free(unixwild); - return 0; + PerlMem_free(tpl); + PerlMem_free(unixified); + PerlMem_free(unixwild); + return 0; } if (!DECC_EFS_CASE_PRESERVE) { - for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++) - if (toLOWER_L1(*cp1) != toLOWER_L1(*cp2)) break; + for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++) + if (toLOWER_L1(*cp1) != toLOWER_L1(*cp2)) break; } segdirs = dirs - totells; /* Min # of dirs we must have left */ for (front = cp2+1; *front; front++) if (*front == '/') segdirs--; if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) { memmove(fspec,cp2+1,end - cp2); - PerlMem_free(tpl); - PerlMem_free(unixified); - PerlMem_free(unixwild); + PerlMem_free(tpl); + PerlMem_free(unixified); + PerlMem_free(unixwild); return 1; } } @@ -9927,19 +9927,19 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM); for (cp1=tplate,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1); cp1++,cp2++) { - if (!DECC_EFS_CASE_PRESERVE) { - *cp2 = toLOWER_L1(*cp1); /* Make lc copy for match */ - } - else { - *cp2 = *cp1; - } + if (!DECC_EFS_CASE_PRESERVE) { + *cp2 = toLOWER_L1(*cp1); /* Make lc copy for match */ + } + else { + *cp2 = *cp1; + } } if (cp1 != '\0') { - PerlMem_free(tpl); - PerlMem_free(unixified); - PerlMem_free(unixwild); - PerlMem_free(lcres); - return 0; /* Path too long. */ + PerlMem_free(tpl); + PerlMem_free(unixified); + PerlMem_free(unixwild); + PerlMem_free(lcres); + return 0; /* Path too long. */ } lcend = cp2; *cp2 = '\0'; /* Pick up with memcpy later */ @@ -9961,21 +9961,21 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) cp1++, cp2++) { if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */ else { - if (!DECC_EFS_CASE_PRESERVE) { - *cp2 = toLOWER_L1(*cp1); /* else lowercase for match */ - } - else { - *cp2 = *cp1; /* else preserve case for match */ - } - } + if (!DECC_EFS_CASE_PRESERVE) { + *cp2 = toLOWER_L1(*cp1); /* else lowercase for match */ + } + else { + *cp2 = *cp1; /* else preserve case for match */ + } + } if (*cp2 == '/') segdirs++; } if (cp1 != ellipsis - 1) { - PerlMem_free(tpl); - PerlMem_free(unixified); - PerlMem_free(unixwild); - PerlMem_free(lcres); - return 0; /* Path too long */ + PerlMem_free(tpl); + PerlMem_free(unixified); + PerlMem_free(unixwild); + PerlMem_free(lcres); + return 0; /* Path too long */ } /* Back up at least as many dirs as in template before matching */ for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--) @@ -9989,11 +9989,11 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; } } if (!match) { - PerlMem_free(tpl); - PerlMem_free(unixified); - PerlMem_free(unixwild); - PerlMem_free(lcres); - return 0; /* Can't find prefix ??? */ + PerlMem_free(tpl); + PerlMem_free(unixified); + PerlMem_free(unixwild); + PerlMem_free(lcres); + return 0; /* Can't find prefix ??? */ } if (match > 1 && opts & 1) { /* This ... wildcard could cover more than one set of dirs (i.e. @@ -10007,24 +10007,24 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) char def[NAM$C_MAXRSS+1], *st; if (getcwd(def, sizeof def,0) == NULL) { - PerlMem_free(unixified); - PerlMem_free(unixwild); - PerlMem_free(lcres); - PerlMem_free(tpl); - return 0; - } - if (!DECC_EFS_CASE_PRESERVE) { - for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++) - if (toLOWER_L1(*cp1) != toLOWER_L1(*cp2)) break; - } + PerlMem_free(unixified); + PerlMem_free(unixwild); + PerlMem_free(lcres); + PerlMem_free(tpl); + return 0; + } + if (!DECC_EFS_CASE_PRESERVE) { + for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++) + if (toLOWER_L1(*cp1) != toLOWER_L1(*cp2)) break; + } segdirs = dirs - totells; /* Min # of dirs we must have left */ for (st = cp2+1; *st; st++) if (*st == '/') segdirs--; if (*cp1 == '\0' && *cp2 == '/') { memmove(fspec,cp2+1,end - cp2); - PerlMem_free(tpl); - PerlMem_free(unixified); - PerlMem_free(unixwild); - PerlMem_free(lcres); + PerlMem_free(tpl); + PerlMem_free(unixified); + PerlMem_free(unixwild); + PerlMem_free(lcres); return 1; } /* Nope -- stick with lcfront from above and keep going. */ @@ -10135,9 +10135,9 @@ void vmsreaddirversions(DIR *dd, int flag) { if (flag) - dd->flags |= PERL_VMSDIR_M_VERSIONS; + dd->flags |= PERL_VMSDIR_M_VERSIONS; else - dd->flags &= ~PERL_VMSDIR_M_VERSIONS; + dd->flags &= ~PERL_VMSDIR_M_VERSIONS; } /*}}}*/ @@ -10199,20 +10199,20 @@ collectversions(pTHX_ DIR *dd) for (context = 0, e->vms_verscount = 0; e->vms_verscount < VERSIZE(e); e->vms_verscount++) { - unsigned long rsts; - unsigned long flags = 0; + unsigned long rsts; + unsigned long flags = 0; #ifdef VMS_LONGNAME_SUPPORT - flags = LIB$M_FIL_LONG_NAMES; + flags = LIB$M_FIL_LONG_NAMES; #endif - tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags); - if (tmpsts == RMS$_NMF || context == 0) break; - _ckvmssts(tmpsts); - buff[VMS_MAXRSS - 1] = '\0'; - if ((p = strchr(buff, ';'))) - e->vms_versions[e->vms_verscount] = atoi(p + 1); - else - e->vms_versions[e->vms_verscount] = -1; + tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags); + if (tmpsts == RMS$_NMF || context == 0) break; + _ckvmssts(tmpsts); + buff[VMS_MAXRSS - 1] = '\0'; + if ((p = strchr(buff, ';'))) + e->vms_versions[e->vms_verscount] = atoi(p + 1); + else + e->vms_versions[e->vms_verscount] = -1; } _ckvmssts(lib$find_file_end(&context)); @@ -10248,7 +10248,7 @@ Perl_readdir(pTHX_ DIR *dd) #endif tmpsts = lib$find_file - (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags); + (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags); if (dd->context == 0) tmpsts = RMS$_NMF; /* None left. (should be set, but make sure) */ @@ -10283,18 +10283,18 @@ Perl_readdir(pTHX_ DIR *dd) /* Skip any directory component and just copy the name. */ sts = vms_split_path (buff, - &v_spec, - &v_len, - &r_spec, - &r_len, - &d_spec, - &d_len, - &n_spec, - &n_len, - &e_spec, - &e_len, - &vs_spec, - &vs_len); + &v_spec, + &v_len, + &r_spec, + &r_len, + &d_spec, + &d_len, + &n_spec, + &n_len, + &e_spec, + &e_len, + &vs_spec, + &vs_len); if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) { @@ -10314,9 +10314,9 @@ Perl_readdir(pTHX_ DIR *dd) } /* Drop NULL extensions on UNIX file specification */ - if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) { - e_len = 0; - e_spec[0] = '\0'; + if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) { + e_len = 0; + e_spec[0] = '\0'; } } @@ -10327,26 +10327,26 @@ Perl_readdir(pTHX_ DIR *dd) /* Convert the filename to UNIX format if needed */ if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) { - /* Translate the encoded characters. */ - /* Fixme: Unicode handling could result in embedded 0 characters */ - if (strchr(dd->entry.d_name, '^') != NULL) { - char new_name[256]; - char * q; - p = dd->entry.d_name; - q = new_name; - while (*p != 0) { - int inchars_read, outchars_added; - inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added); - p += inchars_read; - q += outchars_added; - /* fix-me */ - /* if outchars_added > 1, then this is a wide file specification */ - /* Wide file specifications need to be passed in Perl */ - /* counted strings apparently with a Unicode flag */ - } - *q = 0; - dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name)); - } + /* Translate the encoded characters. */ + /* Fixme: Unicode handling could result in embedded 0 characters */ + if (strchr(dd->entry.d_name, '^') != NULL) { + char new_name[256]; + char * q; + p = dd->entry.d_name; + q = new_name; + while (*p != 0) { + int inchars_read, outchars_added; + inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added); + p += inchars_read; + q += outchars_added; + /* fix-me */ + /* if outchars_added > 1, then this is a wide file specification */ + /* Wide file specifications need to be passed in Perl */ + /* counted strings apparently with a Unicode flag */ + } + *q = 0; + dd->entry.d_namlen = my_strlcpy(dd->entry.d_name, new_name, sizeof(dd->entry.d_name)); + } } dd->entry.vms_verscount = 0; @@ -10401,7 +10401,7 @@ Perl_seekdir(pTHX_ DIR *dd, long count) /* If we haven't done anything yet... */ if (dd->count == 0) - return; + return; /* Remember some state, and clear it. */ old_flags = dd->flags; @@ -10411,7 +10411,7 @@ Perl_seekdir(pTHX_ DIR *dd, long count) /* The increment is in readdir(). */ for (dd->count = 0; dd->count < count; ) - readdir(dd); + readdir(dd); dd->flags = old_flags; @@ -10704,10 +10704,10 @@ setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote, retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags); if (!(retsts & 1) && *s == '$') { _ckvmssts_noperl(lib$find_file_end(&cxt)); - imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--; - retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags); - if (!(retsts&1)) { - _ckvmssts_noperl(lib$find_file_end(&cxt)); + imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--; + retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags); + if (!(retsts&1)) { + _ckvmssts_noperl(lib$find_file_end(&cxt)); retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags); } } @@ -10726,109 +10726,109 @@ setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote, char b[256] = {0,0,0,0}; read(fileno(fp), b, 256); isdcl = isPRINT_L1(b[0]) && isPRINT_L1(b[1]) && isPRINT_L1(b[2]) && isPRINT_L1(b[3]); - if (isdcl) { - int shebang_len; + if (isdcl) { + int shebang_len; - /* Check for script */ - shebang_len = 0; - if ((b[0] == '#') && (b[1] == '!')) - shebang_len = 2; + /* Check for script */ + shebang_len = 0; + if ((b[0] == '#') && (b[1] == '!')) + shebang_len = 2; #ifdef ALTERNATE_SHEBANG - else { - if (strEQ(b, ALTERNATE_SHEBANG)) { - char * perlstr; - perlstr = strstr("perl",b); - if (perlstr == NULL) - shebang_len = 0; + else { + if (strEQ(b, ALTERNATE_SHEBANG)) { + char * perlstr; + perlstr = strstr("perl",b); + if (perlstr == NULL) + shebang_len = 0; else shebang_len = strlen(ALTERNATE_SHEBANG); - } - else - shebang_len = 0; - } + } + else + shebang_len = 0; + } #endif - if (shebang_len > 0) { - int i; - int j; - char tmpspec[NAM$C_MAXRSS + 1]; - - i = shebang_len; - /* Image is following after white space */ - /*--------------------------------------*/ - while (isPRINT_L1(b[i]) && isSPACE_L1(b[i])) - i++; - - j = 0; - while (isPRINT_L1(b[i]) && !isSPACE_L1(b[i])) { - tmpspec[j++] = b[i++]; - if (j >= NAM$C_MAXRSS) - break; - } - tmpspec[j] = '\0'; - - /* There may be some default parameters to the image */ - /*---------------------------------------------------*/ - j = 0; - while (isPRINT_L1(b[i])) { - image_argv[j++] = b[i++]; - if (j >= NAM$C_MAXRSS) - break; - } - while ((j > 0) && !isPRINT_L1(image_argv[j-1])) - j--; - image_argv[j] = 0; - - /* It will need to be converted to VMS format and validated */ - if (tmpspec[0] != '\0') { - char * iname; - - /* Try to find the exact program requested to be run */ - /*---------------------------------------------------*/ - iname = int_rmsexpand - (tmpspec, image_name, ".exe", - PERL_RMSEXPAND_M_VMS, NULL, NULL); - if (iname != NULL) { - if (cando_by_name_int - (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) { - /* MCR prefix needed */ - isdcl = 0; - } - else { - /* Try again with a null type */ - /*----------------------------*/ - iname = int_rmsexpand - (tmpspec, image_name, ".", - PERL_RMSEXPAND_M_VMS, NULL, NULL); - if (iname != NULL) { - if (cando_by_name_int - (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) { - /* MCR prefix needed */ - isdcl = 0; - } - } - } - - /* Did we find the image to run the script? */ - /*------------------------------------------*/ - if (isdcl) { - char *tchr; - - /* Assume DCL or foreign command exists */ - /*--------------------------------------*/ - tchr = strrchr(tmpspec, '/'); - if (tchr != NULL) { - tchr++; - } - else { - tchr = tmpspec; - } - my_strlcpy(image_name, tchr, sizeof(image_name)); - } - } - } - } - } + if (shebang_len > 0) { + int i; + int j; + char tmpspec[NAM$C_MAXRSS + 1]; + + i = shebang_len; + /* Image is following after white space */ + /*--------------------------------------*/ + while (isPRINT_L1(b[i]) && isSPACE_L1(b[i])) + i++; + + j = 0; + while (isPRINT_L1(b[i]) && !isSPACE_L1(b[i])) { + tmpspec[j++] = b[i++]; + if (j >= NAM$C_MAXRSS) + break; + } + tmpspec[j] = '\0'; + + /* There may be some default parameters to the image */ + /*---------------------------------------------------*/ + j = 0; + while (isPRINT_L1(b[i])) { + image_argv[j++] = b[i++]; + if (j >= NAM$C_MAXRSS) + break; + } + while ((j > 0) && !isPRINT_L1(image_argv[j-1])) + j--; + image_argv[j] = 0; + + /* It will need to be converted to VMS format and validated */ + if (tmpspec[0] != '\0') { + char * iname; + + /* Try to find the exact program requested to be run */ + /*---------------------------------------------------*/ + iname = int_rmsexpand + (tmpspec, image_name, ".exe", + PERL_RMSEXPAND_M_VMS, NULL, NULL); + if (iname != NULL) { + if (cando_by_name_int + (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) { + /* MCR prefix needed */ + isdcl = 0; + } + else { + /* Try again with a null type */ + /*----------------------------*/ + iname = int_rmsexpand + (tmpspec, image_name, ".", + PERL_RMSEXPAND_M_VMS, NULL, NULL); + if (iname != NULL) { + if (cando_by_name_int + (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) { + /* MCR prefix needed */ + isdcl = 0; + } + } + } + + /* Did we find the image to run the script? */ + /*------------------------------------------*/ + if (isdcl) { + char *tchr; + + /* Assume DCL or foreign command exists */ + /*--------------------------------------*/ + tchr = strrchr(tmpspec, '/'); + if (tchr != NULL) { + tchr++; + } + else { + tchr = tmpspec; + } + my_strlcpy(image_name, tchr, sizeof(image_name)); + } + } + } + } + } fclose(fp); } if (check_img && isdcl) { @@ -10840,44 +10840,44 @@ setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote, if (cando_by_name(S_IXUSR,0,resspec)) { vmscmd->dsc$a_pointer = (char *)PerlMem_malloc(MAX_DCL_LINE_LENGTH); - if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM); + if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM); if (!isdcl) { my_strlcpy(vmscmd->dsc$a_pointer,"$ MCR ", MAX_DCL_LINE_LENGTH); - if (image_name[0] != 0) { - my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH); - my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH); - } - } else if (image_name[0] != 0) { - my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH); - my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH); + if (image_name[0] != 0) { + my_strlcat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH); + my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH); + } + } else if (image_name[0] != 0) { + my_strlcpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH); + my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH); } else { my_strlcpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH); } if (suggest_quote) *suggest_quote = 1; - /* If there is an image name, use original command */ - if (image_name[0] == 0) - my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH); - else { - rest = cmd; - while (*rest && isSPACE_L1(*rest)) rest++; - } - - if (image_argv[0] != 0) { - my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH); - my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH); - } + /* If there is an image name, use original command */ + if (image_name[0] == 0) + my_strlcat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH); + else { + rest = cmd; + while (*rest && isSPACE_L1(*rest)) rest++; + } + + if (image_argv[0] != 0) { + my_strlcat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH); + my_strlcat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH); + } if (rest) { - int rest_len; - int vmscmd_len; - - rest_len = strlen(rest); - vmscmd_len = strlen(vmscmd->dsc$a_pointer); - if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH) - my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH); - else - retsts = CLI$_BUFOVF; - } + int rest_len; + int vmscmd_len; + + rest_len = strlen(rest); + vmscmd_len = strlen(vmscmd->dsc$a_pointer); + if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH) + my_strlcat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH); + else + retsts = CLI$_BUFOVF; + } vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer); PerlMem_free(cmd); PerlMem_free(vmsspec); @@ -10885,7 +10885,7 @@ setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote, return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts); } else - retsts = RMS$_PRV; + retsts = RMS$_PRV; } } /* It's either a DCL command or we couldn't find a suitable image */ @@ -11021,8 +11021,8 @@ Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp) * waiting for completion -- other values are ignored. */ if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { - ++mark; - flags = SvIVx(*mark); + ++mark; + flags = SvIVx(*mark); } if (flags && flags == 1) /* the Win32 P_NOWAIT value */ @@ -11094,7 +11094,7 @@ do_spawn2(pTHX_ const char *cmd, int flags) set_vaxc_errno(sts); if (ckWARN(WARN_EXEC)) { Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s", - Strerror(errno)); + Strerror(errno)); } } sts = substs; @@ -11227,10 +11227,10 @@ Perl_my_flush(pTHX_ FILE *fp) int res; if ((res = fflush(fp)) == 0 && fp) { #ifdef VMS_DO_SOCKETS - Stat_t s; - if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode)) + Stat_t s; + if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode)) #endif - res = fsync(fileno(fp)); + res = fsync(fileno(fp)); } /* * If the flush succeeded but set end-of-file, we need to clear @@ -11802,7 +11802,7 @@ encode_dev (pTHX_ const char *dev) i = 0; for (q = dev + strlen(dev); q >= dev; q--) { if (*q == ':') - break; + break; if (isdigit (*q)) c= (*q) - '0'; else if (isALPHA_A(toUPPER_A(*q))) @@ -11818,10 +11818,10 @@ encode_dev (pTHX_ const char *dev) } /* end of encode_dev() */ #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \ - device_no = encode_dev(aTHX_ devname) + device_no = encode_dev(aTHX_ devname) #else #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \ - device_no = new_dev_no + device_no = new_dev_no #endif static int @@ -11946,9 +11946,9 @@ Perl_cando_by_name_int(pTHX_ I32 bit, bool effective, const char *fname, int opt break; default: if (fileified != NULL) - PerlMem_free(fileified); + PerlMem_free(fileified); if (vmsname != NULL) - PerlMem_free(vmsname); + PerlMem_free(vmsname); return FALSE; } @@ -12016,7 +12016,7 @@ bool Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp) { return cando_by_name_int - (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN); + (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN); } /* end of cando() */ /*}}}*/ @@ -12047,22 +12047,22 @@ Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp) /* This should not happen, but just in case */ if (cptr == NULL) { - statbufp->st_devnam[0] = 0; + statbufp->st_devnam[0] = 0; } else { - /* Make sure that the saved name fits in 255 characters */ - cptr = int_rmsexpand_vms - (vms_filename, - statbufp->st_devnam, - 0); - if (cptr == NULL) - statbufp->st_devnam[0] = 0; + /* Make sure that the saved name fits in 255 characters */ + cptr = int_rmsexpand_vms + (vms_filename, + statbufp->st_devnam, + 0); + if (cptr == NULL) + statbufp->st_devnam[0] = 0; } PerlMem_free(vms_filename); VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino); VMS_DEVICE_ENCODE - (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev); + (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev); # ifdef VMSISH_TIME if (VMSISH_TIME) { @@ -12098,14 +12098,14 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag) if (decc_bug_devnull != 0) { if (is_null_device(fspec)) { /* Fake a stat() for the null device */ - memset(statbufp,0,sizeof *statbufp); + memset(statbufp,0,sizeof *statbufp); VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0); - statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; - statbufp->st_uid = 0x00010001; - statbufp->st_gid = 0x0001; - time((time_t *)&statbufp->st_mtime); - statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime; - return 0; + statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; + statbufp->st_uid = 0x00010001; + statbufp->st_gid = 0x0001; + time((time_t *)&statbufp->st_mtime); + statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime; + return 0; } } @@ -12181,9 +12181,9 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag) if (!DECC_EFS_CHARSET && (efs_charset_index > 0)) decc$feature_set_value(efs_charset_index, 1, 1); if (lstat_flag == 0) - retval = stat(fspec, &statbufp->crtl_stat); + retval = stat(fspec, &statbufp->crtl_stat); else - retval = lstat(fspec, &statbufp->crtl_stat); + retval = lstat(fspec, &statbufp->crtl_stat); save_spec = fspec; if (!DECC_EFS_CHARSET && (efs_charset_index > 0)) { decc$feature_set_value(efs_charset_index, 1, 0); @@ -12211,7 +12211,7 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag) /* If this is an lstat, do not follow the link */ if (lstat_flag) - rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK; + rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK; /* If we used the efs_hack above, we must also use it here for */ /* perl_cando to work */ @@ -12246,11 +12246,11 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag) /* Fix me: If this is NULL then stat found a file, and we could */ /* not convert the specification to VMS - Should never happen */ if (cptr == NULL) - statbufp->st_devnam[0] = 0; + statbufp->st_devnam[0] = 0; VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino); VMS_DEVICE_ENCODE - (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev); + (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev); # ifdef VMSISH_TIME if (VMSISH_TIME) { statbufp->st_mtime = _toloc(statbufp->st_mtime); @@ -12370,7 +12370,7 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates rms_nam_rsll(nam) = 0; #ifdef NAM$M_NO_SHORT_UPCASE if (DECC_EFS_CASE_PRESERVE) - rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE); + rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE); #endif xabdat = cc$rms_xabdat; /* To get creation date */ @@ -12386,10 +12386,10 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates PerlMem_free(vmsout); PerlMem_free(esa); if (esal != NULL) - PerlMem_free(esal); + PerlMem_free(esal); PerlMem_free(rsa); if (rsal != NULL) - PerlMem_free(rsal); + PerlMem_free(rsal); set_vaxc_errno(sts); switch (sts) { case RMS$_FNF: case RMS$_DNF: @@ -12437,27 +12437,27 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates rms_set_nam_nop(nam_out, NAM$M_SYNCHK); fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */ if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) { - PerlMem_free(vmsin); - PerlMem_free(vmsout); - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - PerlMem_free(rsa); - if (rsal != NULL) - PerlMem_free(rsal); - PerlMem_free(esa_out); - if (esal_out != NULL) - PerlMem_free(esal_out); - PerlMem_free(rsa_out); - if (rsal_out != NULL) - PerlMem_free(rsal_out); + PerlMem_free(vmsin); + PerlMem_free(vmsout); + PerlMem_free(esa); + if (esal != NULL) + PerlMem_free(esal); + PerlMem_free(rsa); + if (rsal != NULL) + PerlMem_free(rsal); + PerlMem_free(esa_out); + if (esal_out != NULL) + PerlMem_free(esal_out); + PerlMem_free(rsa_out); + if (rsal_out != NULL) + PerlMem_free(rsal_out); set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR); set_vaxc_errno(sts); return 0; } fab_out.fab$l_xab = (void *) &xabdat; if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) - preserve_dates = 1; + preserve_dates = 1; } if (preserve_dates < 0) /* Clear all bits; we'll use it as a */ preserve_dates =0; /* bitmask from this point forward */ @@ -12468,16 +12468,16 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates PerlMem_free(vmsout); PerlMem_free(esa); if (esal != NULL) - PerlMem_free(esal); + PerlMem_free(esal); PerlMem_free(rsa); if (rsal != NULL) - PerlMem_free(rsal); + PerlMem_free(rsal); PerlMem_free(esa_out); if (esal_out != NULL) - PerlMem_free(esal_out); + PerlMem_free(esal_out); PerlMem_free(rsa_out); if (rsal_out != NULL) - PerlMem_free(rsal_out); + PerlMem_free(rsal_out); set_vaxc_errno(sts); switch (sts) { case RMS$_DNF: @@ -12517,16 +12517,16 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates PerlMem_free(ubf); PerlMem_free(esa); if (esal != NULL) - PerlMem_free(esal); + PerlMem_free(esal); PerlMem_free(rsa); if (rsal != NULL) - PerlMem_free(rsal); + PerlMem_free(rsal); PerlMem_free(esa_out); if (esal_out != NULL) - PerlMem_free(esal_out); + PerlMem_free(esal_out); PerlMem_free(rsa_out); if (rsal_out != NULL) - PerlMem_free(rsal_out); + PerlMem_free(rsal_out); set_errno(EVMSERR); set_vaxc_errno(sts); return 0; } @@ -12541,16 +12541,16 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates PerlMem_free(ubf); PerlMem_free(esa); if (esal != NULL) - PerlMem_free(esal); + PerlMem_free(esal); PerlMem_free(rsa); if (rsal != NULL) - PerlMem_free(rsal); + PerlMem_free(rsal); PerlMem_free(esa_out); if (esal_out != NULL) - PerlMem_free(esal_out); + PerlMem_free(esal_out); PerlMem_free(rsa_out); if (rsal_out != NULL) - PerlMem_free(rsal_out); + PerlMem_free(rsal_out); set_errno(EVMSERR); set_vaxc_errno(sts); return 0; } @@ -12560,21 +12560,21 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates rab_out.rab$w_rsz = rab_in.rab$w_rsz; if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) { sys$close(&fab_in); sys$close(&fab_out); - PerlMem_free(vmsin); - PerlMem_free(vmsout); - PerlMem_free(ubf); - PerlMem_free(esa); - if (esal != NULL) - PerlMem_free(esal); - PerlMem_free(rsa); - if (rsal != NULL) - PerlMem_free(rsal); - PerlMem_free(esa_out); - if (esal_out != NULL) - PerlMem_free(esal_out); - PerlMem_free(rsa_out); - if (rsal_out != NULL) - PerlMem_free(rsal_out); + PerlMem_free(vmsin); + PerlMem_free(vmsout); + PerlMem_free(ubf); + PerlMem_free(esa); + if (esal != NULL) + PerlMem_free(esal); + PerlMem_free(rsa); + if (rsal != NULL) + PerlMem_free(rsal); + PerlMem_free(esa_out); + if (esal_out != NULL) + PerlMem_free(esal_out); + PerlMem_free(rsa_out); + if (rsal_out != NULL) + PerlMem_free(rsal_out); set_errno(EVMSERR); set_vaxc_errno(sts); return 0; } @@ -12590,16 +12590,16 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates PerlMem_free(ubf); PerlMem_free(esa); if (esal != NULL) - PerlMem_free(esal); + PerlMem_free(esal); PerlMem_free(rsa); if (rsal != NULL) - PerlMem_free(rsal); + PerlMem_free(rsal); PerlMem_free(esa_out); if (esal_out != NULL) - PerlMem_free(esal_out); + PerlMem_free(esal_out); PerlMem_free(rsa_out); if (rsal_out != NULL) - PerlMem_free(rsal_out); + PerlMem_free(rsal_out); if (!(sts & 1)) { set_errno(EVMSERR); set_vaxc_errno(sts); @@ -12645,7 +12645,7 @@ rmsexpand_fromperl(pTHX_ CV *cv) if (rslt != NULL) { sv_usepvn(ST(0),rslt,strlen(rslt)); if (fs_utf8) { - SvUTF8_on(ST(0)); + SvUTF8_on(ST(0)); } } XSRETURN(1); @@ -12666,7 +12666,7 @@ vmsify_fromperl(pTHX_ CV *cv) if (vmsified != NULL) { sv_usepvn(ST(0),vmsified,strlen(vmsified)); if (utf8_fl) { - SvUTF8_on(ST(0)); + SvUTF8_on(ST(0)); } } XSRETURN(1); @@ -12687,7 +12687,7 @@ unixify_fromperl(pTHX_ CV *cv) if (unixified != NULL) { sv_usepvn(ST(0),unixified,strlen(unixified)); if (utf8_fl) { - SvUTF8_on(ST(0)); + SvUTF8_on(ST(0)); } } XSRETURN(1); @@ -12708,7 +12708,7 @@ fileify_fromperl(pTHX_ CV *cv) if (fileified != NULL) { sv_usepvn(ST(0),fileified,strlen(fileified)); if (utf8_fl) { - SvUTF8_on(ST(0)); + SvUTF8_on(ST(0)); } } XSRETURN(1); @@ -12729,7 +12729,7 @@ pathify_fromperl(pTHX_ CV *cv) if (pathified != NULL) { sv_usepvn(ST(0),pathified,strlen(pathified)); if (utf8_fl) { - SvUTF8_on(ST(0)); + SvUTF8_on(ST(0)); } } XSRETURN(1); @@ -12750,7 +12750,7 @@ vmspath_fromperl(pTHX_ CV *cv) if (vmspath != NULL) { sv_usepvn(ST(0),vmspath,strlen(vmspath)); if (utf8_fl) { - SvUTF8_on(ST(0)); + SvUTF8_on(ST(0)); } } XSRETURN(1); @@ -12771,7 +12771,7 @@ unixpath_fromperl(pTHX_ CV *cv) if (unixpath != NULL) { sv_usepvn(ST(0),unixpath,strlen(unixpath)); if (utf8_fl) { - SvUTF8_on(ST(0)); + SvUTF8_on(ST(0)); } } XSRETURN(1); @@ -12917,7 +12917,7 @@ mod2fname(pTHX_ CV *cv) last = 0; for (source = work_name; *source; source++) { if (last == *source && last == '_') { - continue; + continue; } *dest++ = *source; last = *source; @@ -12930,11 +12930,11 @@ mod2fname(pTHX_ CV *cv) last = 0; dest = workbuff; for (source = work_name; *source; source++) { - if (last == toUPPER_A(*source)) { - continue; - } - *dest++ = *source; - last = toUPPER_A(*source); + if (last == toUPPER_A(*source)) { + continue; + } + *dest++ = *source; + last = toUPPER_A(*source); } my_strlcpy(work_name, workbuff, sizeof(work_name)); } @@ -13009,31 +13009,31 @@ Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io) Newx(vmsspec, VMS_MAXRSS, char); - /* We could find out if there's an explicit dev/dir or version - by peeking into lib$find_file's internal context at - ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb - but that's unsupported, so I don't want to do it now and - have it bite someone in the future. */ - /* Fix-me: vms_split_path() is the only way to do this, the - existing method will fail with many legal EFS or UNIX specifications - */ + /* We could find out if there's an explicit dev/dir or version + by peeking into lib$find_file's internal context at + ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb + but that's unsupported, so I don't want to do it now and + have it bite someone in the future. */ + /* Fix-me: vms_split_path() is the only way to do this, the + existing method will fail with many legal EFS or UNIX specifications + */ cp = SvPV(tmpglob,i); for (; i; i--) { - if (cp[i] == ';') hasver = 1; - if (cp[i] == '.') { - if (sts) hasver = 1; - else sts = 1; - } - if (cp[i] == '/') { - hasdir = isunix = 1; - break; - } - if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') { - hasdir = 1; - break; - } + if (cp[i] == ';') hasver = 1; + if (cp[i] == '.') { + if (sts) hasver = 1; + else sts = 1; + } + if (cp[i] == '/') { + hasdir = isunix = 1; + break; + } + if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') { + hasdir = 1; + break; + } } /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */ @@ -13042,15 +13042,15 @@ Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io) } if ((tmpfp = PerlIO_tmpfile()) != NULL) { - char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec; - int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len; - int wildstar = 0; - int wildquery = 0; - int found = 0; - Stat_t st; - int stat_sts; - stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st); - if (!stat_sts && S_ISDIR(st.st_mode)) { + char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec; + int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len; + int wildstar = 0; + int wildquery = 0; + int found = 0; + Stat_t st; + int stat_sts; + stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st); + if (!stat_sts && S_ISDIR(st.st_mode)) { char * vms_dir; const char * fname; STRLEN fname_len; @@ -13076,18 +13076,18 @@ Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io) wilddsc.dsc$a_pointer = st.st_devnam; ok = 1; } - } - else { - wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL); - ok = (wilddsc.dsc$a_pointer != NULL); - } - if (ok) - wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer); - - /* If not extended character set, replace ? with % */ - /* With extended character set, ? is a wildcard single character */ - for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) { - if (*cp == '?') { + } + else { + wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL); + ok = (wilddsc.dsc$a_pointer != NULL); + } + if (ok) + wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer); + + /* If not extended character set, replace ? with % */ + /* With extended character set, ? is a wildcard single character */ + for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) { + if (*cp == '?') { wildquery = 1; if (!DECC_EFS_CHARSET) *cp = '%'; @@ -13096,7 +13096,7 @@ Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io) } else if (*cp == '*') { wildstar = 1; } - } + } if (ok) { wv_sts = vms_split_path( @@ -13110,41 +13110,41 @@ Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io) we_len = 0; } - sts = SS$_NORMAL; - while (ok && $VMS_STATUS_SUCCESS(sts)) { - char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec; - int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len; + sts = SS$_NORMAL; + while (ok && $VMS_STATUS_SUCCESS(sts)) { + char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec; + int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len; int valid_find; valid_find = 0; - sts = lib$find_file(&wilddsc,&rsdsc,&cxt, - &dfltdsc,NULL,&rms_sts,&lff_flags); - if (!$VMS_STATUS_SUCCESS(sts)) - break; - - /* with varying string, 1st word of buffer contains result length */ - rstr[rslt->length] = '\0'; - - /* Find where all the components are */ - v_sts = vms_split_path - (rstr, - &v_spec, - &v_len, - &r_spec, - &r_len, - &d_spec, - &d_len, - &n_spec, - &n_len, - &e_spec, - &e_len, - &vs_spec, - &vs_len); - - /* If no version on input, truncate the version on output */ - if (!hasver && (vs_len > 0)) { - *vs_spec = '\0'; - vs_len = 0; + sts = lib$find_file(&wilddsc,&rsdsc,&cxt, + &dfltdsc,NULL,&rms_sts,&lff_flags); + if (!$VMS_STATUS_SUCCESS(sts)) + break; + + /* with varying string, 1st word of buffer contains result length */ + rstr[rslt->length] = '\0'; + + /* Find where all the components are */ + v_sts = vms_split_path + (rstr, + &v_spec, + &v_len, + &r_spec, + &r_len, + &d_spec, + &d_len, + &n_spec, + &n_len, + &e_spec, + &e_len, + &vs_spec, + &vs_len); + + /* If no version on input, truncate the version on output */ + if (!hasver && (vs_len > 0)) { + *vs_spec = '\0'; + vs_len = 0; } if (isunix) { @@ -13165,16 +13165,16 @@ Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io) } } - /* No version & a null extension on UNIX handling */ - if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) { - e_len = 0; - *e_spec = '\0'; - } - } + /* No version & a null extension on UNIX handling */ + if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) { + e_len = 0; + *e_spec = '\0'; + } + } - if (!DECC_EFS_CASE_PRESERVE) { - for (cp = rstr; *cp; cp++) *cp = toLOWER_L1(*cp); - } + if (!DECC_EFS_CASE_PRESERVE) { + for (cp = rstr; *cp; cp++) *cp = toLOWER_L1(*cp); + } /* Find File treats a Null extension as return all extensions */ /* This is contrary to Perl expectations */ @@ -13202,44 +13202,44 @@ Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io) } if (valid_find) { - found++; - - if (hasdir) { - if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1); - begin = rstr; - } - else { - /* Start with the name */ - begin = n_spec; - } - strcat(begin,"\n"); - ok = (PerlIO_puts(tmpfp,begin) != EOF); + found++; + + if (hasdir) { + if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1); + begin = rstr; + } + else { + /* Start with the name */ + begin = n_spec; + } + strcat(begin,"\n"); + ok = (PerlIO_puts(tmpfp,begin) != EOF); + } + } + if (cxt) (void)lib$find_file_end(&cxt); + + if (!found) { + /* Be POSIXish: return the input pattern when no matches */ + my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS); + strcat(rstr,"\n"); + ok = (PerlIO_puts(tmpfp,rstr) != EOF); + } + + if (ok && sts != RMS$_NMF && + sts != RMS$_DNF && sts != RMS_FNF) ok = 0; + if (!ok) { + if (!(sts & 1)) { + SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts); } - } - if (cxt) (void)lib$find_file_end(&cxt); - - if (!found) { - /* Be POSIXish: return the input pattern when no matches */ - my_strlcpy(rstr, SvPVX(tmpglob), VMS_MAXRSS); - strcat(rstr,"\n"); - ok = (PerlIO_puts(tmpfp,rstr) != EOF); - } - - if (ok && sts != RMS$_NMF && - sts != RMS$_DNF && sts != RMS_FNF) ok = 0; - if (!ok) { - if (!(sts & 1)) { - SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts); - } - PerlIO_close(tmpfp); - fp = NULL; - } - else { - PerlIO_rewind(tmpfp); - IoTYPE(io) = IoTYPE_RDONLY; - IoIFP(io) = fp = tmpfp; - IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ - } + PerlIO_close(tmpfp); + fp = NULL; + } + else { + PerlIO_rewind(tmpfp); + IoTYPE(io) = IoTYPE_RDONLY; + IoIFP(io) = fp = tmpfp; + IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ + } } Safefree(vmsspec); Safefree(rslt); @@ -13249,7 +13249,7 @@ Perl_vms_start_glob(pTHX_ SV *tmpglob, IO *io) static char * mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, - int *utf8_fl); + int *utf8_fl); void unixrealpath_fromperl(pTHX_ CV *cv) @@ -13259,7 +13259,7 @@ unixrealpath_fromperl(pTHX_ CV *cv) STRLEN n_a; if (!items || items != 1) - Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)"); + Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)"); fspec = SvPV(ST(0),n_a); if (!fspec || !*fspec) XSRETURN_UNDEF; @@ -13269,15 +13269,15 @@ unixrealpath_fromperl(pTHX_ CV *cv) ST(0) = sv_newmortal(); if (rslt != NULL) - sv_usepvn(ST(0),rslt,strlen(rslt)); + sv_usepvn(ST(0),rslt,strlen(rslt)); else - Safefree(rslt_spec); - XSRETURN(1); + Safefree(rslt_spec); + XSRETURN(1); } static char * mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec, - int *utf8_fl); + int *utf8_fl); void vmsrealpath_fromperl(pTHX_ CV *cv) @@ -13287,7 +13287,7 @@ vmsrealpath_fromperl(pTHX_ CV *cv) STRLEN n_a; if (!items || items != 1) - Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)"); + Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)"); fspec = SvPV(ST(0),n_a); if (!fspec || !*fspec) XSRETURN_UNDEF; @@ -13297,10 +13297,10 @@ vmsrealpath_fromperl(pTHX_ CV *cv) ST(0) = sv_newmortal(); if (rslt != NULL) - sv_usepvn(ST(0),rslt,strlen(rslt)); + sv_usepvn(ST(0),rslt,strlen(rslt)); else - Safefree(rslt_spec); - XSRETURN(1); + Safefree(rslt_spec); + XSRETURN(1); } #ifdef HAS_SYMLINK @@ -13537,22 +13537,22 @@ int vms_fid_to_name(char * outname, int outlen, if (sts == 0) { int vms_sts; - dvidsc.dsc$a_pointer=statbuf.st_dev; + dvidsc.dsc$a_pointer=statbuf.st_dev; dvidsc.dsc$w_length=strlen(statbuf.st_dev); - specdsc.dsc$a_pointer = outname; - specdsc.dsc$w_length = outlen-1; + specdsc.dsc$a_pointer = outname; + specdsc.dsc$w_length = outlen-1; vms_sts = lib$fid_to_name - (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length); + (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length); if ($VMS_STATUS_SUCCESS(vms_sts)) { - outname[specdsc.dsc$w_length] = 0; + outname[specdsc.dsc$w_length] = 0; /* Return the mode */ if (mode) { *mode = statbuf.old_st_mode; } - } + } } PerlMem_free(temp_fspec); PerlMem_free(fileified); @@ -13563,16 +13563,16 @@ int vms_fid_to_name(char * outname, int outlen, static char * mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, - int *utf8_fl) + int *utf8_fl) { char * rslt = NULL; #ifdef HAS_SYMLINK if (DECC_POSIX_COMPLIANT_PATHNAMES) { - /* realpath currently only works if posix compliant pathnames are - * enabled. It may start working when they are not, but in that - * case we still want the fallback behavior for backwards compatibility - */ + /* realpath currently only works if posix compliant pathnames are + * enabled. It may start working when they are not, but in that + * case we still want the fallback behavior for backwards compatibility + */ rslt = realpath(filespec, outbuf); } #endif @@ -13583,159 +13583,159 @@ mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int sts, v_len, r_len, d_len, n_len, e_len, vs_len; mode_t my_mode; - /* Fall back to fid_to_name */ + /* Fall back to fid_to_name */ Newx(vms_spec, VMS_MAXRSS + 1, char); - sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode); - if (sts == 0) { - - - /* Now need to trim the version off */ - sts = vms_split_path - (vms_spec, - &v_spec, - &v_len, - &r_spec, - &r_len, - &d_spec, - &d_len, - &n_spec, - &n_len, - &e_spec, - &e_len, - &vs_spec, - &vs_len); - - - if (sts == 0) { - int haslower = 0; - const char *cp; - - /* Trim off the version */ - int file_len = v_len + r_len + d_len + n_len + e_len; - vms_spec[file_len] = 0; - - /* Trim off the .DIR if this is a directory */ - if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) { + sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode); + if (sts == 0) { + + + /* Now need to trim the version off */ + sts = vms_split_path + (vms_spec, + &v_spec, + &v_len, + &r_spec, + &r_len, + &d_spec, + &d_len, + &n_spec, + &n_len, + &e_spec, + &e_len, + &vs_spec, + &vs_len); + + + if (sts == 0) { + int haslower = 0; + const char *cp; + + /* Trim off the version */ + int file_len = v_len + r_len + d_len + n_len + e_len; + vms_spec[file_len] = 0; + + /* Trim off the .DIR if this is a directory */ + if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) { if (S_ISDIR(my_mode)) { e_len = 0; e_spec[0] = 0; } - } + } - /* Drop NULL extensions on UNIX file specification */ - if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) { - e_len = 0; - e_spec[0] = '\0'; - } + /* Drop NULL extensions on UNIX file specification */ + if ((e_len == 1) && DECC_READDIR_DROPDOTNOTYPE) { + e_len = 0; + e_spec[0] = '\0'; + } - /* The result is expected to be in UNIX format */ - rslt = int_tounixspec(vms_spec, outbuf, utf8_fl); + /* The result is expected to be in UNIX format */ + rslt = int_tounixspec(vms_spec, outbuf, utf8_fl); /* Downcase if input had any lower case letters and - * case preservation is not in effect. - */ - if (!DECC_EFS_CASE_PRESERVE) { - for (cp = filespec; *cp; cp++) - if (islower(*cp)) { haslower = 1; break; } - - if (haslower) __mystrtolower(rslt); - } - } - } else { - - /* Now for some hacks to deal with backwards and forward */ - /* compatibility */ - if (!DECC_EFS_CHARSET) { - - /* 1. ODS-2 mode wants to do a syntax only translation */ - rslt = int_rmsexpand(filespec, outbuf, - NULL, 0, NULL, utf8_fl); - - } else { - if (DECC_FILENAME_UNIX_REPORT) { - char * dir_name; - char * vms_dir_name; - char * file_name; - - /* 2. ODS-5 / UNIX report mode should return a failure */ - /* if the parent directory also does not exist */ - /* Otherwise, get the real path for the parent */ - /* and add the child to it. */ - - /* basename / dirname only available for VMS 7.0+ */ - /* So we may need to implement them as common routines */ - - Newx(dir_name, VMS_MAXRSS + 1, char); - Newx(vms_dir_name, VMS_MAXRSS + 1, char); - dir_name[0] = '\0'; - file_name = NULL; - - /* First try a VMS parse */ - sts = vms_split_path - (filespec, - &v_spec, - &v_len, - &r_spec, - &r_len, - &d_spec, - &d_len, - &n_spec, - &n_len, - &e_spec, - &e_len, - &vs_spec, - &vs_len); - - if (sts == 0) { - /* This is VMS */ - - int dir_len = v_len + r_len + d_len + n_len; - if (dir_len > 0) { - memcpy(dir_name, filespec, dir_len); - dir_name[dir_len] = '\0'; - file_name = (char *)&filespec[dir_len + 1]; - } - } else { - /* This must be UNIX */ - char * tchar; - - tchar = strrchr(filespec, '/'); - - if (tchar != NULL) { - int dir_len = tchar - filespec; - memcpy(dir_name, filespec, dir_len); - dir_name[dir_len] = '\0'; - file_name = (char *) &filespec[dir_len + 1]; - } - } - - /* Dir name is defaulted */ - if (dir_name[0] == 0) { - dir_name[0] = '.'; - dir_name[1] = '\0'; - } - - /* Need realpath for the directory */ - sts = vms_fid_to_name(vms_dir_name, - VMS_MAXRSS + 1, - dir_name, 0, NULL); - - if (sts == 0) { - /* Now need to pathify it. */ - char *tdir = int_pathify_dirspec(vms_dir_name, - outbuf); - - /* And now add the original filespec to it */ - if (file_name != NULL) { - my_strlcat(outbuf, file_name, VMS_MAXRSS); - } - return outbuf; - } - Safefree(vms_dir_name); - Safefree(dir_name); - } + * case preservation is not in effect. + */ + if (!DECC_EFS_CASE_PRESERVE) { + for (cp = filespec; *cp; cp++) + if (islower(*cp)) { haslower = 1; break; } + + if (haslower) __mystrtolower(rslt); + } + } + } else { + + /* Now for some hacks to deal with backwards and forward */ + /* compatibility */ + if (!DECC_EFS_CHARSET) { + + /* 1. ODS-2 mode wants to do a syntax only translation */ + rslt = int_rmsexpand(filespec, outbuf, + NULL, 0, NULL, utf8_fl); + + } else { + if (DECC_FILENAME_UNIX_REPORT) { + char * dir_name; + char * vms_dir_name; + char * file_name; + + /* 2. ODS-5 / UNIX report mode should return a failure */ + /* if the parent directory also does not exist */ + /* Otherwise, get the real path for the parent */ + /* and add the child to it. */ + + /* basename / dirname only available for VMS 7.0+ */ + /* So we may need to implement them as common routines */ + + Newx(dir_name, VMS_MAXRSS + 1, char); + Newx(vms_dir_name, VMS_MAXRSS + 1, char); + dir_name[0] = '\0'; + file_name = NULL; + + /* First try a VMS parse */ + sts = vms_split_path + (filespec, + &v_spec, + &v_len, + &r_spec, + &r_len, + &d_spec, + &d_len, + &n_spec, + &n_len, + &e_spec, + &e_len, + &vs_spec, + &vs_len); + + if (sts == 0) { + /* This is VMS */ + + int dir_len = v_len + r_len + d_len + n_len; + if (dir_len > 0) { + memcpy(dir_name, filespec, dir_len); + dir_name[dir_len] = '\0'; + file_name = (char *)&filespec[dir_len + 1]; + } + } else { + /* This must be UNIX */ + char * tchar; + + tchar = strrchr(filespec, '/'); + + if (tchar != NULL) { + int dir_len = tchar - filespec; + memcpy(dir_name, filespec, dir_len); + dir_name[dir_len] = '\0'; + file_name = (char *) &filespec[dir_len + 1]; + } + } + + /* Dir name is defaulted */ + if (dir_name[0] == 0) { + dir_name[0] = '.'; + dir_name[1] = '\0'; + } + + /* Need realpath for the directory */ + sts = vms_fid_to_name(vms_dir_name, + VMS_MAXRSS + 1, + dir_name, 0, NULL); + + if (sts == 0) { + /* Now need to pathify it. */ + char *tdir = int_pathify_dirspec(vms_dir_name, + outbuf); + + /* And now add the original filespec to it */ + if (file_name != NULL) { + my_strlcat(outbuf, file_name, VMS_MAXRSS); + } + return outbuf; + } + Safefree(vms_dir_name); + Safefree(dir_name); + } } } Safefree(vms_spec); @@ -13745,7 +13745,7 @@ mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, static char * mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf, - int *utf8_fl) + int *utf8_fl) { char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec; int sts, v_len, r_len, d_len, n_len, e_len, vs_len; @@ -13754,46 +13754,46 @@ mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf, sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL); if (sts != 0) { - return NULL; + return NULL; } else { - /* Now need to trim the version off */ - sts = vms_split_path - (outbuf, - &v_spec, - &v_len, - &r_spec, - &r_len, - &d_spec, - &d_len, - &n_spec, - &n_len, - &e_spec, - &e_len, - &vs_spec, - &vs_len); - - - if (sts == 0) { - int haslower = 0; - const char *cp; - - /* Trim off the version */ - int file_len = v_len + r_len + d_len + n_len + e_len; - outbuf[file_len] = 0; - - /* Downcase if input had any lower case letters and - * case preservation is not in effect. - */ - if (!DECC_EFS_CASE_PRESERVE) { - for (cp = filespec; *cp; cp++) - if (islower(*cp)) { haslower = 1; break; } - - if (haslower) __mystrtolower(outbuf); - } - } + /* Now need to trim the version off */ + sts = vms_split_path + (outbuf, + &v_spec, + &v_len, + &r_spec, + &r_len, + &d_spec, + &d_len, + &n_spec, + &n_len, + &e_spec, + &e_len, + &vs_spec, + &vs_len); + + + if (sts == 0) { + int haslower = 0; + const char *cp; + + /* Trim off the version */ + int file_len = v_len + r_len + d_len + n_len + e_len; + outbuf[file_len] = 0; + + /* Downcase if input had any lower case letters and + * case preservation is not in effect. + */ + if (!DECC_EFS_CASE_PRESERVE) { + for (cp = filespec; *cp; cp++) + if (islower(*cp)) { haslower = 1; break; } + + if (haslower) __mystrtolower(outbuf); + } + } } return outbuf; } @@ -13849,7 +13849,7 @@ set_feature_default(const char *name, int value) if (status) { val_str[0] = toUPPER_A(val_str[0]); if (val_str[0] == 'D' || val_str[0] == '0' || val_str[0] == 'F') - return 0; + return 0; } } @@ -13901,20 +13901,20 @@ vmsperl_set_features(void) if (status) { val_str[0] = toUPPER_A(val_str[0]); if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) - vms_debug_on_exception = 1; + vms_debug_on_exception = 1; else - vms_debug_on_exception = 0; + vms_debug_on_exception = 0; } /* Debug unix/vms file translation routines */ vms_debug_fileify = 0; status = simple_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str)); if (status) { - val_str[0] = toUPPER_A(val_str[0]); + val_str[0] = toUPPER_A(val_str[0]); if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) - vms_debug_fileify = 1; + vms_debug_fileify = 1; else - vms_debug_fileify = 0; + vms_debug_fileify = 0; } @@ -13930,11 +13930,11 @@ vmsperl_set_features(void) vms_bug_stat_filename = 0; status = simple_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str)); if (status) { - val_str[0] = toUPPER_A(val_str[0]); + val_str[0] = toUPPER_A(val_str[0]); if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) - vms_bug_stat_filename = 1; + vms_bug_stat_filename = 1; else - vms_bug_stat_filename = 0; + vms_bug_stat_filename = 0; } @@ -13944,9 +13944,9 @@ vmsperl_set_features(void) if (status) { val_str[0] = toUPPER_A(val_str[0]); if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) - vms_vtf7_filenames = 1; + vms_vtf7_filenames = 1; else - vms_vtf7_filenames = 0; + vms_vtf7_filenames = 0; } /* unlink all versions on unlink() or rename() */ @@ -13955,9 +13955,9 @@ vmsperl_set_features(void) if (status) { val_str[0] = toUPPER_A(val_str[0]); if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) - vms_unlink_all_versions = 1; + vms_unlink_all_versions = 1; else - vms_unlink_all_versions = 0; + vms_unlink_all_versions = 0; } /* The path separator in PERL5LIB is '|' unless running under a Unix shell. */ @@ -13967,17 +13967,17 @@ vmsperl_set_features(void) gnv_unix_shell = 0; status = simple_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str)); if (status) { - gnv_unix_shell = 1; - set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1); - set_feature_default("DECC$FILENAME_UNIX_REPORT", 1); - set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1); - set_feature_default("DECC$DISABLE_POSIX_ROOT", 0); - vms_unlink_all_versions = 1; - vms_posix_exit = 1; - /* Reverse default ordering of PERL_ENV_TABLES. */ - defenv[0] = &crtlenvdsc; - defenv[1] = &fildevdsc; - PL_perllib_sep = ':'; + gnv_unix_shell = 1; + set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1); + set_feature_default("DECC$FILENAME_UNIX_REPORT", 1); + set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1); + set_feature_default("DECC$DISABLE_POSIX_ROOT", 0); + vms_unlink_all_versions = 1; + vms_posix_exit = 1; + /* Reverse default ordering of PERL_ENV_TABLES. */ + defenv[0] = &crtlenvdsc; + defenv[1] = &fildevdsc; + PL_perllib_sep = ':'; } /* Some reasonable defaults that are not CRTL defaults */ set_feature_default("DECC$EFS_CASE_PRESERVE", 1); @@ -14008,7 +14008,7 @@ vmsperl_set_features(void) if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) decc_bug_devnull = 1; else - decc_bug_devnull = 0; + decc_bug_devnull = 0; } s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION"); @@ -14043,13 +14043,13 @@ vmsperl_set_features(void) /*----------------------------*/ status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0); if (!$VMS_STATUS_SUCCESS(status)) - case_perm = PPROP$K_CASE_BLIND; + case_perm = PPROP$K_CASE_BLIND; status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0); if (!$VMS_STATUS_SUCCESS(status)) - case_image = PPROP$K_CASE_BLIND; + case_image = PPROP$K_CASE_BLIND; if ((case_perm == PPROP$K_CASE_SENSITIVE) || - (case_image == PPROP$K_CASE_SENSITIVE)) - vms_process_case_tolerant = 0; + (case_image == PPROP$K_CASE_SENSITIVE)) + vms_process_case_tolerant = 0; #endif @@ -14059,9 +14059,9 @@ vmsperl_set_features(void) if (status) { val_str[0] = toUPPER_A(val_str[0]); if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) - vms_posix_exit = 1; + vms_posix_exit = 1; else - vms_posix_exit = 0; + vms_posix_exit = 0; } } diff --git a/vms/vmsish.h b/vms/vmsish.h index a0003e90bc..ed3b299ce3 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -320,8 +320,8 @@ struct interp_intern { # define PERL_FS_VER_FMT "%d_%d_%d" #endif #define PERL_FS_VERSION STRINGIFY(PERL_REVISION) "_" \ - STRINGIFY(PERL_VERSION) "_" \ - STRINGIFY(PERL_SUBVERSION) + STRINGIFY(PERL_VERSION) "_" \ + STRINGIFY(PERL_SUBVERSION) /* Temporary; we need to add support for this to Configure.Com */ #ifdef PERL_INC_VERSION_LIST # undef PERL_INC_VERSION_LIST diff --git a/win32/fcrypt.c b/win32/fcrypt.c index 4433e684c9..edc80b19dd 100644 --- a/win32/fcrypt.c +++ b/win32/fcrypt.c @@ -13,15 +13,15 @@ typedef unsigned char des_cblock[8]; typedef struct des_ks_struct - { - union { - des_cblock _; - /* make sure things are correct size on machines with - * 8 byte longs */ - unsigned long pad[2]; - } ks; + { + union { + des_cblock _; + /* make sure things are correct size on machines with + * 8 byte longs */ + unsigned long pad[2]; + } ks; #define _ ks._ - } des_key_schedule[16]; + } des_key_schedule[16]; #define DES_KEY_SZ (sizeof(des_cblock)) #define DES_ENCRYPT 1 @@ -31,14 +31,14 @@ typedef struct des_ks_struct #define HALF_ITERATIONS 8 #define c2l(c,l) (l =((unsigned long)(*((c)++))) , \ - l|=((unsigned long)(*((c)++)))<< 8, \ - l|=((unsigned long)(*((c)++)))<<16, \ - l|=((unsigned long)(*((c)++)))<<24) + l|=((unsigned long)(*((c)++)))<< 8, \ + l|=((unsigned long)(*((c)++)))<<16, \ + l|=((unsigned long)(*((c)++)))<<24) #define l2c(l,c) (*((c)++)=(unsigned char)(((l) )&0xff), \ - *((c)++)=(unsigned char)(((l)>> 8)&0xff), \ - *((c)++)=(unsigned char)(((l)>>16)&0xff), \ - *((c)++)=(unsigned char)(((l)>>24)&0xff)) + *((c)++)=(unsigned char)(((l)>> 8)&0xff), \ + *((c)++)=(unsigned char)(((l)>>16)&0xff), \ + *((c)++)=(unsigned char)(((l)>>24)&0xff)) static const unsigned long SPtrans[8][64]={ { /* nibble 0 */ @@ -319,77 +319,77 @@ static const unsigned long skb[8][64]={ /* See ecb_encrypt.c for a pseudo description of these macros. */ #define PERM_OP(a,b,t,n,m) ((t)=((((a)>>(n))^(b))&(m)),\ - (b)^=(t),\ - (a)^=((t)<<(n))) + (b)^=(t),\ + (a)^=((t)<<(n))) #define HPERM_OP(a,t,n,m) ((t)=((((a)<<(16-(n)))^(a))&(m)),\ - (a)=(a)^(t)^(t>>(16-(n))))\ + (a)=(a)^(t)^(t>>(16-(n))))\ static const char shifts2[16]={0,0,1,1,1,1,1,1,0,1,1,1,1,1,1,0}; static int body( - unsigned long *out0, - unsigned long *out1, - des_key_schedule ks, - unsigned long Eswap0, - unsigned long Eswap1); + unsigned long *out0, + unsigned long *out1, + des_key_schedule ks, + unsigned long Eswap0, + unsigned long Eswap1); static int des_set_key(des_cblock *key, des_key_schedule schedule) - { - unsigned long c,d,t,s; - unsigned char *in; - unsigned long *k; - int i; - - k=(unsigned long *)schedule; - in=(unsigned char *)key; - - c2l(in,c); - c2l(in,d); - - /* I now do it in 47 simple operations :-) - * Thanks to John Fletcher (john_fletcher@lccmail.ocf.llnl.gov) - * for the inspiration. :-) */ - PERM_OP (d,c,t,4,0x0f0f0f0f); - HPERM_OP(c,t,-2,0xcccc0000); - HPERM_OP(d,t,-2,0xcccc0000); - PERM_OP (d,c,t,1,0x55555555); - PERM_OP (c,d,t,8,0x00ff00ff); - PERM_OP (d,c,t,1,0x55555555); - d= (((d&0x000000ff)<<16)| (d&0x0000ff00) | - ((d&0x00ff0000)>>16)|((c&0xf0000000)>>4)); - c&=0x0fffffff; - - for (i=0; i<ITERATIONS; i++) - { - if (shifts2[i]) - { c=((c>>2)|(c<<26)); d=((d>>2)|(d<<26)); } - else - { c=((c>>1)|(c<<27)); d=((d>>1)|(d<<27)); } - c&=0x0fffffff; - d&=0x0fffffff; - /* could be a few less shifts but I am to lazy at this - * point in time to investigate */ - s= skb[0][ (c )&0x3f ]| - skb[1][((c>> 6)&0x03)|((c>> 7)&0x3c)]| - skb[2][((c>>13)&0x0f)|((c>>14)&0x30)]| - skb[3][((c>>20)&0x01)|((c>>21)&0x06) | - ((c>>22)&0x38)]; - t= skb[4][ (d )&0x3f ]| - skb[5][((d>> 7)&0x03)|((d>> 8)&0x3c)]| - skb[6][ (d>>15)&0x3f ]| - skb[7][((d>>21)&0x0f)|((d>>22)&0x30)]; - - /* table contained 0213 4657 */ - *(k++)=((t<<16)|(s&0x0000ffff))&0xffffffff; - s= ((s>>16)|(t&0xffff0000)); - - s=(s<<4)|(s>>28); - *(k++)=s&0xffffffff; - } - return(0); - } + { + unsigned long c,d,t,s; + unsigned char *in; + unsigned long *k; + int i; + + k=(unsigned long *)schedule; + in=(unsigned char *)key; + + c2l(in,c); + c2l(in,d); + + /* I now do it in 47 simple operations :-) + * Thanks to John Fletcher (john_fletcher@lccmail.ocf.llnl.gov) + * for the inspiration. :-) */ + PERM_OP (d,c,t,4,0x0f0f0f0f); + HPERM_OP(c,t,-2,0xcccc0000); + HPERM_OP(d,t,-2,0xcccc0000); + PERM_OP (d,c,t,1,0x55555555); + PERM_OP (c,d,t,8,0x00ff00ff); + PERM_OP (d,c,t,1,0x55555555); + d= (((d&0x000000ff)<<16)| (d&0x0000ff00) | + ((d&0x00ff0000)>>16)|((c&0xf0000000)>>4)); + c&=0x0fffffff; + + for (i=0; i<ITERATIONS; i++) + { + if (shifts2[i]) + { c=((c>>2)|(c<<26)); d=((d>>2)|(d<<26)); } + else + { c=((c>>1)|(c<<27)); d=((d>>1)|(d<<27)); } + c&=0x0fffffff; + d&=0x0fffffff; + /* could be a few less shifts but I am to lazy at this + * point in time to investigate */ + s= skb[0][ (c )&0x3f ]| + skb[1][((c>> 6)&0x03)|((c>> 7)&0x3c)]| + skb[2][((c>>13)&0x0f)|((c>>14)&0x30)]| + skb[3][((c>>20)&0x01)|((c>>21)&0x06) | + ((c>>22)&0x38)]; + t= skb[4][ (d )&0x3f ]| + skb[5][((d>> 7)&0x03)|((d>> 8)&0x3c)]| + skb[6][ (d>>15)&0x3f ]| + skb[7][((d>>21)&0x0f)|((d>>22)&0x30)]; + + /* table contained 0213 4657 */ + *(k++)=((t<<16)|(s&0x0000ffff))&0xffffffff; + s= ((s>>16)|(t&0xffff0000)); + + s=(s<<4)|(s>>28); + *(k++)=s&0xffffffff; + } + return(0); + } /****************************************************************** * modified stuff for crypt. @@ -402,37 +402,37 @@ des_set_key(des_cblock *key, des_key_schedule schedule) */ #ifdef ALT_ECB #define D_ENCRYPT(L,R,S) \ - v=(R^(R>>16)); \ - u=(v&E0); \ - v=(v&E1); \ - u=((u^(u<<16))^R^s[S ])<<2; \ - t=(v^(v<<16))^R^s[S+1]; \ - t=(t>>2)|(t<<30); \ - L^= \ - *(unsigned long *)(des_SP+0x0100+((t )&0xfc))+ \ - *(unsigned long *)(des_SP+0x0300+((t>> 8)&0xfc))+ \ - *(unsigned long *)(des_SP+0x0500+((t>>16)&0xfc))+ \ - *(unsigned long *)(des_SP+0x0700+((t>>24)&0xfc))+ \ - *(unsigned long *)(des_SP+ ((u )&0xfc))+ \ - *(unsigned long *)(des_SP+0x0200+((u>> 8)&0xfc))+ \ - *(unsigned long *)(des_SP+0x0400+((u>>16)&0xfc))+ \ - *(unsigned long *)(des_SP+0x0600+((u>>24)&0xfc)); + v=(R^(R>>16)); \ + u=(v&E0); \ + v=(v&E1); \ + u=((u^(u<<16))^R^s[S ])<<2; \ + t=(v^(v<<16))^R^s[S+1]; \ + t=(t>>2)|(t<<30); \ + L^= \ + *(unsigned long *)(des_SP+0x0100+((t )&0xfc))+ \ + *(unsigned long *)(des_SP+0x0300+((t>> 8)&0xfc))+ \ + *(unsigned long *)(des_SP+0x0500+((t>>16)&0xfc))+ \ + *(unsigned long *)(des_SP+0x0700+((t>>24)&0xfc))+ \ + *(unsigned long *)(des_SP+ ((u )&0xfc))+ \ + *(unsigned long *)(des_SP+0x0200+((u>> 8)&0xfc))+ \ + *(unsigned long *)(des_SP+0x0400+((u>>16)&0xfc))+ \ + *(unsigned long *)(des_SP+0x0600+((u>>24)&0xfc)); #else /* original version */ #define D_ENCRYPT(L,R,S) \ - v=(R^(R>>16)); \ - u=(v&E0); \ - v=(v&E1); \ - u=(u^(u<<16))^R^s[S ]; \ - t=(v^(v<<16))^R^s[S+1]; \ - t=(t>>4)|(t<<28); \ - L^= SPtrans[1][(t )&0x3f]| \ - SPtrans[3][(t>> 8)&0x3f]| \ - SPtrans[5][(t>>16)&0x3f]| \ - SPtrans[7][(t>>24)&0x3f]| \ - SPtrans[0][(u )&0x3f]| \ - SPtrans[2][(u>> 8)&0x3f]| \ - SPtrans[4][(u>>16)&0x3f]| \ - SPtrans[6][(u>>24)&0x3f]; + v=(R^(R>>16)); \ + u=(v&E0); \ + v=(v&E1); \ + u=(u^(u<<16))^R^s[S ]; \ + t=(v^(v<<16))^R^s[S+1]; \ + t=(t>>4)|(t<<28); \ + L^= SPtrans[1][(t )&0x3f]| \ + SPtrans[3][(t>> 8)&0x3f]| \ + SPtrans[5][(t>>16)&0x3f]| \ + SPtrans[7][(t>>24)&0x3f]| \ + SPtrans[0][(u )&0x3f]| \ + SPtrans[2][(u>> 8)&0x3f]| \ + SPtrans[4][(u>>16)&0x3f]| \ + SPtrans[6][(u>>24)&0x3f]; #endif unsigned const char con_salt[128]={ @@ -475,119 +475,119 @@ unsigned const char cov_2char[64]={ char * des_fcrypt(const char *buf, const char *salt, char *buff) - { - unsigned int i,j,x,y; - unsigned long Eswap0,Eswap1; - unsigned long out[2],ll; - des_cblock key; - des_key_schedule ks; - unsigned char bb[9]; - unsigned char *b=bb; - unsigned char c,u; + { + unsigned int i,j,x,y; + unsigned long Eswap0,Eswap1; + unsigned long out[2],ll; + des_cblock key; + des_key_schedule ks; + unsigned char bb[9]; + unsigned char *b=bb; + unsigned char c,u; if (!good_for_salt(salt[0]) || !good_for_salt(salt[1])) { errno = EINVAL; return NULL; } - /* eay 25/08/92 - * If you call crypt("pwd","*") as often happens when you - * have * as the pwd field in /etc/passwd, the function - * returns *\0XXXXXXXXX - * The \0 makes the string look like * so the pwd "*" would - * crypt to "*". This was found when replacing the crypt in - * our shared libraries. People found that the disbled - * accounts effectivly had no passwd :-(. */ - x=buff[0]=((salt[0] == '\0')?(char)'A':salt[0]); - Eswap0=con_salt[x]; - x=buff[1]=((salt[1] == '\0')?(char)'A':salt[1]); - Eswap1=con_salt[x]<<4; - - for (i=0; i<8; i++) - { - c= *(buf++); - if (!c) break; - key[i]=(char)(c<<1); - } - for (; i<8; i++) - key[i]=0; - - des_set_key((des_cblock *)(key),ks); - body(&out[0],&out[1],ks,Eswap0,Eswap1); - - ll=out[0]; l2c(ll,b); - ll=out[1]; l2c(ll,b); - y=0; - u=0x80; - bb[8]=0; - for (i=2; i<13; i++) - { - c=0; - for (j=0; j<6; j++) - { - c<<=1; - if (bb[y] & u) c|=1; - u>>=1; - if (!u) - { - y++; - u=0x80; - } - } - buff[i]=cov_2char[c]; - } - buff[13]='\0'; - return buff; - } + /* eay 25/08/92 + * If you call crypt("pwd","*") as often happens when you + * have * as the pwd field in /etc/passwd, the function + * returns *\0XXXXXXXXX + * The \0 makes the string look like * so the pwd "*" would + * crypt to "*". This was found when replacing the crypt in + * our shared libraries. People found that the disbled + * accounts effectivly had no passwd :-(. */ + x=buff[0]=((salt[0] == '\0')?(char)'A':salt[0]); + Eswap0=con_salt[x]; + x=buff[1]=((salt[1] == '\0')?(char)'A':salt[1]); + Eswap1=con_salt[x]<<4; + + for (i=0; i<8; i++) + { + c= *(buf++); + if (!c) break; + key[i]=(char)(c<<1); + } + for (; i<8; i++) + key[i]=0; + + des_set_key((des_cblock *)(key),ks); + body(&out[0],&out[1],ks,Eswap0,Eswap1); + + ll=out[0]; l2c(ll,b); + ll=out[1]; l2c(ll,b); + y=0; + u=0x80; + bb[8]=0; + for (i=2; i<13; i++) + { + c=0; + for (j=0; j<6; j++) + { + c<<=1; + if (bb[y] & u) c|=1; + u>>=1; + if (!u) + { + y++; + u=0x80; + } + } + buff[i]=cov_2char[c]; + } + buff[13]='\0'; + return buff; + } static int body( unsigned long *out0, - unsigned long *out1, - des_key_schedule ks, - unsigned long Eswap0, - unsigned long Eswap1) - { - unsigned long l,r,t,u,v; + unsigned long *out1, + des_key_schedule ks, + unsigned long Eswap0, + unsigned long Eswap1) + { + unsigned long l,r,t,u,v; #ifdef ALT_ECB - unsigned char *des_SP=(unsigned char *)SPtrans; + unsigned char *des_SP=(unsigned char *)SPtrans; #endif - unsigned long *s; - int i,j; - unsigned long E0,E1; - - l=0; - r=0; - - s=(unsigned long *)ks; - E0=Eswap0; - E1=Eswap1; - - for (j=0; j<25; j++) - { - for (i=0; i<(ITERATIONS*2); i+=4) - { - D_ENCRYPT(l,r, i); /* 1 */ - D_ENCRYPT(r,l, i+2); /* 2 */ - } - t=l; - l=r; - r=t; - } - t=r; - r=(l>>1)|(l<<31); - l=(t>>1)|(t<<31); - /* clear the top bits on machines with 8byte longs */ - l&=0xffffffff; - r&=0xffffffff; - - PERM_OP(r,l,t, 1,0x55555555); - PERM_OP(l,r,t, 8,0x00ff00ff); - PERM_OP(r,l,t, 2,0x33333333); - PERM_OP(l,r,t,16,0x0000ffff); - PERM_OP(r,l,t, 4,0x0f0f0f0f); - - *out0=l; - *out1=r; - return(0); - } + unsigned long *s; + int i,j; + unsigned long E0,E1; + + l=0; + r=0; + + s=(unsigned long *)ks; + E0=Eswap0; + E1=Eswap1; + + for (j=0; j<25; j++) + { + for (i=0; i<(ITERATIONS*2); i+=4) + { + D_ENCRYPT(l,r, i); /* 1 */ + D_ENCRYPT(r,l, i+2); /* 2 */ + } + t=l; + l=r; + r=t; + } + t=r; + r=(l>>1)|(l<<31); + l=(t>>1)|(t<<31); + /* clear the top bits on machines with 8byte longs */ + l&=0xffffffff; + r&=0xffffffff; + + PERM_OP(r,l,t, 1,0x55555555); + PERM_OP(l,r,t, 8,0x00ff00ff); + PERM_OP(r,l,t, 2,0x33333333); + PERM_OP(l,r,t,16,0x0000ffff); + PERM_OP(r,l,t, 4,0x0f0f0f0f); + + *out0=l; + *out1=r; + return(0); + } diff --git a/win32/include/dirent.h b/win32/include/dirent.h index 5037825425..9396743c0d 100644 --- a/win32/include/dirent.h +++ b/win32/include/dirent.h @@ -24,21 +24,21 @@ /* structure of a directory entry */ typedef struct direct { - long d_ino; /* inode number (not used by MS-DOS) */ - long d_namlen; /* name length */ - char d_name[257]; /* file name */ + long d_ino; /* inode number (not used by MS-DOS) */ + long d_namlen; /* name length */ + char d_name[257]; /* file name */ } _DIRECT; /* structure for dir operations */ typedef struct _dir_struc { - char *start; /* starting position */ - char *curr; /* current position */ - long size; /* allocated size of string table */ - long nfiles; /* number of filenames in table */ - struct direct dirstr; /* directory structure to return */ - void* handle; /* system handle */ - char *end; /* position after last filename */ + char *start; /* starting position */ + char *curr; /* current position */ + long size; /* allocated size of string table */ + long nfiles; /* number of filenames in table */ + struct direct dirstr; /* directory structure to return */ + void* handle; /* system handle */ + char *end; /* position after last filename */ } DIR; #if 0 /* these have moved to win32iop.h */ diff --git a/win32/include/sys/socket.h b/win32/include/sys/socket.h index 5374a806f5..8f93fa0429 100644 --- a/win32/include/sys/socket.h +++ b/win32/include/sys/socket.h @@ -73,7 +73,7 @@ int win32_recv (SOCKET s, char * buf, int len, int flags); int win32_recvfrom (SOCKET s, char * buf, int len, int flags, struct sockaddr *from, int * fromlen); int win32_select (int nfds, Perl_fd_set *rfds, Perl_fd_set *wfds, Perl_fd_set *xfds, - const struct timeval *timeout); + const struct timeval *timeout); int win32_send (SOCKET s, const char * buf, int len, int flags); int win32_sendto (SOCKET s, const char * buf, int len, int flags, const struct sockaddr *to, int tolen); diff --git a/win32/perlglob.c b/win32/perlglob.c index 305fd3bee5..09061a4de0 100644 --- a/win32/perlglob.c +++ b/win32/perlglob.c @@ -40,12 +40,12 @@ main(int argc, char *argv[]) /* check out the file system characteristics */ if (GetFullPathName(".", MAX_PATH, root, &dummy)) { dummy = strchr(root,'\\'); - if (dummy) - *++dummy = '\0'; - if (GetVolumeInformation(root, volname, MAX_PATH, - &serial, &maxname, &flags, 0, 0)) { - downcase = !(flags & FS_CASE_IS_PRESERVED); - } + if (dummy) + *++dummy = '\0'; + if (GetVolumeInformation(root, volname, MAX_PATH, + &serial, &maxname, &flags, 0, 0)) { + downcase = !(flags & FS_CASE_IS_PRESERVED); + } } fd = fileno(stdout); @@ -56,11 +56,11 @@ main(int argc, char *argv[]) assert(fd >= 0 && fd < SHRT_MAX); setmode(fd, O_BINARY); for (i = 1; i < argc; i++) { - len = strlen(argv[i]); - if (downcase) - strlwr(argv[i]); - if (i > 1) fwrite("\0", sizeof(char), 1, stdout); - fwrite(argv[i], sizeof(char), len, stdout); + len = strlen(argv[i]); + if (downcase) + strlwr(argv[i]); + if (i > 1) fwrite("\0", sizeof(char), 1, stdout); + fwrite(argv[i], sizeof(char), len, stdout); } return 0; } diff --git a/win32/perlhost.h b/win32/perlhost.h index 6d12abf252..5ce496590f 100644 --- a/win32/perlhost.h +++ b/win32/perlhost.h @@ -32,10 +32,10 @@ public: /* Constructors */ CPerlHost(void); CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, - struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, - struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, - struct IPerlDir** ppDir, struct IPerlSock** ppSock, - struct IPerlProc** ppProc); + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc); CPerlHost(CPerlHost& host); ~CPerlHost(void); @@ -61,11 +61,11 @@ public: inline void Free(void* ptr) { m_pVMem->Free(ptr); }; inline void* Calloc(size_t num, size_t size) { - size_t count = num*size; - void* lpVoid = Malloc(count); - if (lpVoid) - ZeroMemory(lpVoid, count); - return lpVoid; + size_t count = num*size; + void* lpVoid = Malloc(count); + if (lpVoid) + ZeroMemory(lpVoid, count); + return lpVoid; }; inline void GetLock(void) { m_pVMem->GetLock(); }; inline void FreeLock(void) { m_pVMem->FreeLock(); }; @@ -78,33 +78,33 @@ public: inline int IsLockedShared(void) { return m_pVMemShared->IsLocked(); }; inline void* MallocShared(size_t size) { - void *result; - GetLockShared(); - result = m_pVMemShared->Malloc(size); - FreeLockShared(); - return result; + void *result; + GetLockShared(); + result = m_pVMemShared->Malloc(size); + FreeLockShared(); + return result; }; inline void* ReallocShared(void* ptr, size_t size) { - void *result; - GetLockShared(); - result = m_pVMemShared->Realloc(ptr, size); - FreeLockShared(); - return result; + void *result; + GetLockShared(); + result = m_pVMemShared->Realloc(ptr, size); + FreeLockShared(); + return result; }; inline void FreeShared(void* ptr) { - GetLockShared(); - m_pVMemShared->Free(ptr); - FreeLockShared(); + GetLockShared(); + m_pVMemShared->Free(ptr); + FreeLockShared(); }; inline void* CallocShared(size_t num, size_t size) { - size_t count = num*size; - void* lpVoid = MallocShared(count); - if (lpVoid) - ZeroMemory(lpVoid, count); - return lpVoid; + size_t count = num*size; + void* lpVoid = MallocShared(count); + if (lpVoid) + ZeroMemory(lpVoid, count); + return lpVoid; }; /* IPerlMemParse */ @@ -119,11 +119,11 @@ public: inline void FreeParse(void* ptr) { m_pVMemParse->Free(ptr); }; inline void* CallocParse(size_t num, size_t size) { - size_t count = num*size; - void* lpVoid = MallocParse(count); - if (lpVoid) - ZeroMemory(lpVoid, count); - return lpVoid; + size_t count = num*size; + void* lpVoid = MallocParse(count); + if (lpVoid) + ZeroMemory(lpVoid, count); + return lpVoid; }; /* IPerlEnv */ @@ -131,11 +131,11 @@ public: int Putenv(const char *envstring); inline char *Getenv(const char *varname, unsigned long *len) { - *len = 0; - char *e = Getenv(varname); - if (e) - *len = strlen(e); - return e; + *len = 0; + char *e = Getenv(varname); + if (e) + *len = strlen(e); + return e; } void* CreateChildEnv(void) { return CreateLocalEnvironmentStrings(*m_pvDir); }; void FreeChildEnv(void* pStr) { FreeLocalEnvironmentStrings((char*)pStr); }; @@ -146,12 +146,12 @@ public: inline LPSTR GetIndex(DWORD &dwIndex) { - if(dwIndex < m_dwEnvCount) - { - ++dwIndex; - return m_lppEnvList[dwIndex-1]; - } - return NULL; + if(dwIndex < m_dwEnvCount) + { + ++dwIndex; + return m_lppEnvList[dwIndex-1]; + } + return NULL; }; protected: @@ -524,7 +524,7 @@ PerlEnvSiteLibPath(struct IPerlEnv* piPerl, const char *pl, STRLEN *const len) char* PerlEnvVendorLibPath(struct IPerlEnv* piPerl, const char *pl, - STRLEN *const len) + STRLEN *const len) { return win32_get_vendorlib(pl, len); } @@ -833,17 +833,17 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf) /* open the file in the same mode */ if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) { - mode[0] = 'r'; - mode[1] = 0; + mode[0] = 'r'; + mode[1] = 0; } else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) { - mode[0] = 'a'; - mode[1] = 0; + mode[0] = 'a'; + mode[1] = 0; } else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) { - mode[0] = 'r'; - mode[1] = '+'; - mode[2] = 0; + mode[0] = 'r'; + mode[1] = '+'; + mode[2] = 0; } /* it appears that the binmode is attached to the @@ -854,7 +854,7 @@ PerlStdIOFdupopen(struct IPerlStdIO* piPerl, FILE* pf) /* move the file pointer to the same position */ if (!fgetpos(pf, &pos)) { - fsetpos(pfdup, &pos); + fsetpos(pfdup, &pos); } return pfdup; } @@ -1724,24 +1724,24 @@ win32_start_child(LPVOID arg) /* push a zero on the stack (we are the child) */ { - dSP; - dTARGET; - PUSHi(0); - PUTBACK; + dSP; + dTARGET; + PUSHi(0); + PUTBACK; } /* continue from next op */ PL_op = PL_op->op_next; { - dJMPENV; - volatile int oldscope = 1; /* We are responsible for all scopes */ + dJMPENV; + volatile int oldscope = 1; /* We are responsible for all scopes */ restart: - JMPENV_PUSH(status); - switch (status) { - case 0: - CALLRUNOPS(aTHX); + JMPENV_PUSH(status); + switch (status) { + case 0: + CALLRUNOPS(aTHX); /* We may have additional unclosed scopes if fork() was called * from within a BEGIN block. See perlfork.pod for more details. * We cannot clean up these other scopes because they belong to a @@ -1752,48 +1752,48 @@ restart: PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1]; PL_scopestack_ix = oldscope; } - status = 0; - break; - case 2: - while (PL_scopestack_ix > oldscope) - LEAVE; - FREETMPS; - PL_curstash = PL_defstash; - if (PL_curstash != PL_defstash) { - SvREFCNT_dec(PL_curstash); - PL_curstash = (HV *)SvREFCNT_inc(PL_defstash); - } - if (PL_endav && !PL_minus_c) { - PERL_SET_PHASE(PERL_PHASE_END); - call_list(oldscope, PL_endav); - } - status = STATUS_EXIT; - break; - case 3: - if (PL_restartop) { - POPSTACK_TO(PL_mainstack); - PL_op = PL_restartop; - PL_restartop = (OP*)NULL; - goto restart; - } - PerlIO_printf(Perl_error_log, "panic: restartop\n"); - FREETMPS; - status = 1; - break; - } - JMPENV_POP; - - /* XXX hack to avoid perl_destruct() freeing optree */ + status = 0; + break; + case 2: + while (PL_scopestack_ix > oldscope) + LEAVE; + FREETMPS; + PL_curstash = PL_defstash; + if (PL_curstash != PL_defstash) { + SvREFCNT_dec(PL_curstash); + PL_curstash = (HV *)SvREFCNT_inc(PL_defstash); + } + if (PL_endav && !PL_minus_c) { + PERL_SET_PHASE(PERL_PHASE_END); + call_list(oldscope, PL_endav); + } + status = STATUS_EXIT; + break; + case 3: + if (PL_restartop) { + POPSTACK_TO(PL_mainstack); + PL_op = PL_restartop; + PL_restartop = (OP*)NULL; + goto restart; + } + PerlIO_printf(Perl_error_log, "panic: restartop\n"); + FREETMPS; + status = 1; + break; + } + JMPENV_POP; + + /* XXX hack to avoid perl_destruct() freeing optree */ win32_checkTLS(my_perl); - PL_main_root = (OP*)NULL; + PL_main_root = (OP*)NULL; } win32_checkTLS(my_perl); /* close the std handles to avoid fd leaks */ { - do_close(PL_stdingv, FALSE); - do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE); /* PL_stdoutgv - ISAGN */ - do_close(PL_stderrgv, FALSE); + do_close(PL_stdingv, FALSE); + do_close(gv_fetchpv("STDOUT", TRUE, SVt_PVIO), FALSE); /* PL_stdoutgv - ISAGN */ + do_close(PL_stderrgv, FALSE); } /* destroy everything (waits for any pseudo-forked children) */ @@ -1820,22 +1820,22 @@ PerlProcFork(struct IPerlProc* piPerl) CPerlHost *h; if (w32_num_pseudo_children >= MAXIMUM_WAIT_OBJECTS) { - errno = EAGAIN; - return -1; + errno = EAGAIN; + return -1; } h = new CPerlHost(*(CPerlHost*)w32_internal_host); PerlInterpreter *new_perl = perl_clone_using((PerlInterpreter*)aTHX, - CLONEf_COPY_STACKS, - h->m_pHostperlMem, - h->m_pHostperlMemShared, - h->m_pHostperlMemParse, - h->m_pHostperlEnv, - h->m_pHostperlStdIO, - h->m_pHostperlLIO, - h->m_pHostperlDir, - h->m_pHostperlSock, - h->m_pHostperlProc - ); + CLONEf_COPY_STACKS, + h->m_pHostperlMem, + h->m_pHostperlMemShared, + h->m_pHostperlMemParse, + h->m_pHostperlEnv, + h->m_pHostperlStdIO, + h->m_pHostperlLIO, + h->m_pHostperlDir, + h->m_pHostperlSock, + h->m_pHostperlProc + ); new_perl->Isys_intern.internal_host = h; h->host_perl = new_perl; # ifdef PERL_SYNC_FORK @@ -1849,15 +1849,15 @@ PerlProcFork(struct IPerlProc* piPerl) (w32_message_hwnd == NULL) ? (HWND)NULL : (HWND)INVALID_HANDLE_VALUE; # ifdef USE_RTL_THREAD_API handle = (HANDLE)_beginthreadex((void*)NULL, 0, win32_start_child, - (void*)new_perl, 0, (unsigned*)&id); + (void*)new_perl, 0, (unsigned*)&id); # else handle = CreateThread(NULL, 0, win32_start_child, - (LPVOID)new_perl, 0, &id); + (LPVOID)new_perl, 0, &id); # endif PERL_SET_THX(aTHX); /* XXX perl_clone*() set TLS */ if (!handle) { - errno = EAGAIN; - return -1; + errno = EAGAIN; + return -1; } w32_pseudo_child_handles[w32_num_pseudo_children] = handle; w32_pseudo_child_pids[w32_num_pseudo_children] = id; @@ -1985,20 +1985,20 @@ CPerlHost::CPerlHost(void) #define SETUPEXCHANGE(xptr, iptr, table) \ STMT_START { \ - if (xptr) { \ - iptr = *xptr; \ - *xptr = &table; \ - } \ - else { \ - iptr = &table; \ - } \ + if (xptr) { \ + iptr = *xptr; \ + *xptr = &table; \ + } \ + else { \ + iptr = &table; \ + } \ } STMT_END CPerlHost::CPerlHost(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, - struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, - struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, - struct IPerlDir** ppDir, struct IPerlSock** ppSock, - struct IPerlProc** ppProc) + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc) { InterlockedIncrement(&num_hosts); m_pvDir = new VDir(0); @@ -2073,7 +2073,7 @@ CPerlHost::CPerlHost(CPerlHost& host) LPSTR lpPtr; DWORD dwIndex = 0; while(lpPtr = host.GetIndex(dwIndex)) - Add(lpPtr); + Add(lpPtr); } CPerlHost::~CPerlHost(void) @@ -2092,13 +2092,13 @@ CPerlHost::Find(LPCSTR lpStr) LPSTR lpPtr; LPSTR* lppPtr = Lookup(lpStr); if(lppPtr != NULL) { - for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr) - ; + for(lpPtr = *lppPtr; *lpPtr != '\0' && *lpPtr != '='; ++lpPtr) + ; - if(*lpPtr == '=') - ++lpPtr; + if(*lpPtr == '=') + ++lpPtr; - return lpPtr; + return lpPtr; } return NULL; } @@ -2112,26 +2112,26 @@ lookup(const void *arg1, const void *arg2) ptr1 = *(char**)arg1; ptr2 = *(char**)arg2; for(;;) { - c1 = *ptr1++; - c2 = *ptr2++; - if(c1 == '\0' || c1 == '=') { - if(c2 == '\0' || c2 == '=') - break; - - return -1; // string 1 < string 2 - } - else if(c2 == '\0' || c2 == '=') - return 1; // string 1 > string 2 - else if(c1 != c2) { - c1 = toupper(c1); - c2 = toupper(c2); - if(c1 != c2) { - if(c1 < c2) - return -1; // string 1 < string 2 - - return 1; // string 1 > string 2 - } - } + c1 = *ptr1++; + c2 = *ptr2++; + if(c1 == '\0' || c1 == '=') { + if(c2 == '\0' || c2 == '=') + break; + + return -1; // string 1 < string 2 + } + else if(c2 == '\0' || c2 == '=') + return 1; // string 1 > string 2 + else if(c1 != c2) { + c1 = toupper(c1); + c2 = toupper(c2); + if(c1 != c2) { + if(c1 < c2) + return -1; // string 1 < string 2 + + return 1; // string 1 > string 2 + } + } } return 0; } @@ -2140,7 +2140,7 @@ LPSTR* CPerlHost::Lookup(LPCSTR lpStr) { if (!lpStr) - return NULL; + return NULL; return (LPSTR*)bsearch(&lpStr, m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), lookup); } @@ -2153,26 +2153,26 @@ compare(const void *arg1, const void *arg2) ptr1 = *(char**)arg1; ptr2 = *(char**)arg2; for(;;) { - c1 = *ptr1++; - c2 = *ptr2++; - if(c1 == '\0' || c1 == '=') { - if(c1 == c2) - break; - - return -1; // string 1 < string 2 - } - else if(c2 == '\0' || c2 == '=') - return 1; // string 1 > string 2 - else if(c1 != c2) { - c1 = toupper(c1); - c2 = toupper(c2); - if(c1 != c2) { - if(c1 < c2) - return -1; // string 1 < string 2 - - return 1; // string 1 > string 2 - } - } + c1 = *ptr1++; + c2 = *ptr2++; + if(c1 == '\0' || c1 == '=') { + if(c1 == c2) + break; + + return -1; // string 1 < string 2 + } + else if(c2 == '\0' || c2 == '=') + return 1; // string 1 > string 2 + else if(c1 != c2) { + c1 = toupper(c1); + c2 = toupper(c2); + if(c1 != c2) { + if(c1 < c2) + return -1; // string 1 < string 2 + + return 1; // string 1 > string 2 + } + } } return 0; } @@ -2186,23 +2186,23 @@ CPerlHost::Add(LPCSTR lpStr) // replacing ? lpPtr = Lookup(lpStr); if (lpPtr != NULL) { - // must allocate things via host memory allocation functions - // rather than perl's Renew() et al, as the perl interpreter - // may either not be initialized enough when we allocate these, - // or may already be dead when we go to free these - *lpPtr = (char*)Realloc(*lpPtr, length * sizeof(char)); - strcpy(*lpPtr, lpStr); + // must allocate things via host memory allocation functions + // rather than perl's Renew() et al, as the perl interpreter + // may either not be initialized enough when we allocate these, + // or may already be dead when we go to free these + *lpPtr = (char*)Realloc(*lpPtr, length * sizeof(char)); + strcpy(*lpPtr, lpStr); } else { - m_lppEnvList = (LPSTR*)Realloc(m_lppEnvList, (m_dwEnvCount+1) * sizeof(LPSTR)); - if (m_lppEnvList) { - m_lppEnvList[m_dwEnvCount] = (char*)Malloc(length * sizeof(char)); - if (m_lppEnvList[m_dwEnvCount] != NULL) { - strcpy(m_lppEnvList[m_dwEnvCount], lpStr); - ++m_dwEnvCount; - qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare); - } - } + m_lppEnvList = (LPSTR*)Realloc(m_lppEnvList, (m_dwEnvCount+1) * sizeof(LPSTR)); + if (m_lppEnvList) { + m_lppEnvList[m_dwEnvCount] = (char*)Malloc(length * sizeof(char)); + if (m_lppEnvList[m_dwEnvCount] != NULL) { + strcpy(m_lppEnvList[m_dwEnvCount], lpStr); + ++m_dwEnvCount; + qsort(m_lppEnvList, m_dwEnvCount, sizeof(LPSTR), compare); + } + } } } @@ -2212,7 +2212,7 @@ CPerlHost::CalculateEnvironmentSpace(void) DWORD index; DWORD dwSize = 0; for(index = 0; index < m_dwEnvCount; ++index) - dwSize += strlen(m_lppEnvList[index]) + 1; + dwSize += strlen(m_lppEnvList[index]) + 1; return dwSize; } @@ -2257,13 +2257,13 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir) // step over current directory stuff while(*lpTmp == '=') - lpTmp += strlen(lpTmp) + 1; + lpTmp += strlen(lpTmp) + 1; // save the start of the environment strings lpEnvPtr = lpTmp; for(dwSize = 1; *lpTmp != '\0'; lpTmp += strlen(lpTmp) + 1) { - // calculate the size of the environment strings - dwSize += strlen(lpTmp) + 1; + // calculate the size of the environment strings + dwSize += strlen(lpTmp) + 1; } // add the size of current directories @@ -2275,57 +2275,57 @@ CPerlHost::CreateLocalEnvironmentStrings(VDir &vDir) Newx(lpStr, dwSize, char); lpPtr = lpStr; if(lpStr != NULL) { - // build the local environment - lpStr = vDir.BuildEnvironmentSpace(lpStr); - - dwEnvIndex = 0; - lpLocalEnv = GetIndex(dwEnvIndex); - while(*lpEnvPtr != '\0') { - if(!lpLocalEnv) { - // all environment overrides have been added - // so copy string into place - strcpy(lpStr, lpEnvPtr); - nLength = strlen(lpEnvPtr) + 1; - lpStr += nLength; - lpEnvPtr += nLength; - } - else { - // determine which string to copy next - compVal = compare(&lpEnvPtr, &lpLocalEnv); - if(compVal < 0) { - strcpy(lpStr, lpEnvPtr); - nLength = strlen(lpEnvPtr) + 1; - lpStr += nLength; - lpEnvPtr += nLength; - } - else { - char *ptr = strchr(lpLocalEnv, '='); - if(ptr && ptr[1]) { - strcpy(lpStr, lpLocalEnv); - lpStr += strlen(lpLocalEnv) + 1; - } - lpLocalEnv = GetIndex(dwEnvIndex); - if(compVal == 0) { - // this string was replaced - lpEnvPtr += strlen(lpEnvPtr) + 1; - } - } - } - } - - while(lpLocalEnv) { - // still have environment overrides to add - // so copy the strings into place if not an override - char *ptr = strchr(lpLocalEnv, '='); - if(ptr && ptr[1]) { - strcpy(lpStr, lpLocalEnv); - lpStr += strlen(lpLocalEnv) + 1; - } - lpLocalEnv = GetIndex(dwEnvIndex); - } - - // add final NULL - *lpStr = '\0'; + // build the local environment + lpStr = vDir.BuildEnvironmentSpace(lpStr); + + dwEnvIndex = 0; + lpLocalEnv = GetIndex(dwEnvIndex); + while(*lpEnvPtr != '\0') { + if(!lpLocalEnv) { + // all environment overrides have been added + // so copy string into place + strcpy(lpStr, lpEnvPtr); + nLength = strlen(lpEnvPtr) + 1; + lpStr += nLength; + lpEnvPtr += nLength; + } + else { + // determine which string to copy next + compVal = compare(&lpEnvPtr, &lpLocalEnv); + if(compVal < 0) { + strcpy(lpStr, lpEnvPtr); + nLength = strlen(lpEnvPtr) + 1; + lpStr += nLength; + lpEnvPtr += nLength; + } + else { + char *ptr = strchr(lpLocalEnv, '='); + if(ptr && ptr[1]) { + strcpy(lpStr, lpLocalEnv); + lpStr += strlen(lpLocalEnv) + 1; + } + lpLocalEnv = GetIndex(dwEnvIndex); + if(compVal == 0) { + // this string was replaced + lpEnvPtr += strlen(lpEnvPtr) + 1; + } + } + } + } + + while(lpLocalEnv) { + // still have environment overrides to add + // so copy the strings into place if not an override + char *ptr = strchr(lpLocalEnv, '='); + if(ptr && ptr[1]) { + strcpy(lpStr, lpLocalEnv); + lpStr += strlen(lpLocalEnv) + 1; + } + lpLocalEnv = GetIndex(dwEnvIndex); + } + + // add final NULL + *lpStr = '\0'; } // release the process environment strings @@ -2338,10 +2338,10 @@ void CPerlHost::Reset(void) { if(m_lppEnvList != NULL) { - for(DWORD index = 0; index < m_dwEnvCount; ++index) { - Free(m_lppEnvList[index]); - m_lppEnvList[index] = NULL; - } + for(DWORD index = 0; index < m_dwEnvCount; ++index) { + Free(m_lppEnvList[index]); + m_lppEnvList[index] = NULL; + } } m_dwEnvCount = 0; Free(m_lppEnvList); @@ -2354,13 +2354,13 @@ CPerlHost::Clearenv(void) char ch; LPSTR lpPtr, lpStr, lpEnvPtr; if (m_lppEnvList != NULL) { - /* set every entry to an empty string */ - for(DWORD index = 0; index < m_dwEnvCount; ++index) { - char* ptr = strchr(m_lppEnvList[index], '='); - if(ptr) { - *++ptr = 0; - } - } + /* set every entry to an empty string */ + for(DWORD index = 0; index < m_dwEnvCount; ++index) { + char* ptr = strchr(m_lppEnvList[index], '='); + if(ptr) { + *++ptr = 0; + } + } } /* get the process environment strings */ @@ -2368,19 +2368,19 @@ CPerlHost::Clearenv(void) /* step over current directory stuff */ while(*lpStr == '=') - lpStr += strlen(lpStr) + 1; + lpStr += strlen(lpStr) + 1; while(*lpStr) { - lpPtr = strchr(lpStr, '='); - if(lpPtr) { - ch = *++lpPtr; - *lpPtr = 0; - Add(lpStr); - if (m_bTopLevel) - (void)win32_putenv(lpStr); - *lpPtr = ch; - } - lpStr += strlen(lpStr) + 1; + lpPtr = strchr(lpStr, '='); + if(lpPtr) { + ch = *++lpPtr; + *lpPtr = 0; + Add(lpStr); + if (m_bTopLevel) + (void)win32_putenv(lpStr); + *lpPtr = ch; + } + lpStr += strlen(lpStr) + 1; } win32_freeenvironmentstrings(lpEnvPtr); @@ -2391,9 +2391,9 @@ char* CPerlHost::Getenv(const char *varname) { if (!m_bTopLevel) { - char *pEnv = Find(varname); - if (pEnv && *pEnv) - return pEnv; + char *pEnv = Find(varname); + if (pEnv && *pEnv) + return pEnv; } return win32_getenv(varname); } @@ -2403,7 +2403,7 @@ CPerlHost::Putenv(const char *envstring) { Add(envstring); if (m_bTopLevel) - return win32_putenv(envstring); + return win32_putenv(envstring); return 0; } @@ -2413,12 +2413,12 @@ CPerlHost::Chdir(const char *dirname) { int ret; if (!dirname) { - errno = ENOENT; - return -1; + errno = ENOENT; + return -1; } ret = m_pvDir->SetCurrentDirectoryA((char*)dirname); if(ret < 0) { - errno = ENOENT; + errno = ENOENT; } return ret; } diff --git a/win32/perllib.c b/win32/perllib.c index 9948a1a3ba..a8fe7af9c0 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -51,85 +51,85 @@ win32_checkTLS(PerlInterpreter *host_perl) { dTHX; if (host_perl != my_perl) { - int *nowhere = NULL; - abort(); + int *nowhere = NULL; + abort(); } } EXTERN_C void perl_get_host_info(struct IPerlMemInfo* perlMemInfo, - struct IPerlMemInfo* perlMemSharedInfo, - struct IPerlMemInfo* perlMemParseInfo, - struct IPerlEnvInfo* perlEnvInfo, - struct IPerlStdIOInfo* perlStdIOInfo, - struct IPerlLIOInfo* perlLIOInfo, - struct IPerlDirInfo* perlDirInfo, - struct IPerlSockInfo* perlSockInfo, - struct IPerlProcInfo* perlProcInfo) + struct IPerlMemInfo* perlMemSharedInfo, + struct IPerlMemInfo* perlMemParseInfo, + struct IPerlEnvInfo* perlEnvInfo, + struct IPerlStdIOInfo* perlStdIOInfo, + struct IPerlLIOInfo* perlLIOInfo, + struct IPerlDirInfo* perlDirInfo, + struct IPerlSockInfo* perlSockInfo, + struct IPerlProcInfo* perlProcInfo) { if (perlMemInfo) { - Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); - perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); + Copy(&perlMem, &perlMemInfo->perlMemList, perlMemInfo->nCount, void*); + perlMemInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); } if (perlMemSharedInfo) { - Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*); - perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); + Copy(&perlMem, &perlMemSharedInfo->perlMemList, perlMemSharedInfo->nCount, void*); + perlMemSharedInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); } if (perlMemParseInfo) { - Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*); - perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); + Copy(&perlMem, &perlMemParseInfo->perlMemList, perlMemParseInfo->nCount, void*); + perlMemParseInfo->nCount = (sizeof(struct IPerlMem)/sizeof(void*)); } if (perlEnvInfo) { - Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); - perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); + Copy(&perlEnv, &perlEnvInfo->perlEnvList, perlEnvInfo->nCount, void*); + perlEnvInfo->nCount = (sizeof(struct IPerlEnv)/sizeof(void*)); } if (perlStdIOInfo) { - Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); - perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); + Copy(&perlStdIO, &perlStdIOInfo->perlStdIOList, perlStdIOInfo->nCount, void*); + perlStdIOInfo->nCount = (sizeof(struct IPerlStdIO)/sizeof(void*)); } if (perlLIOInfo) { - Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); - perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); + Copy(&perlLIO, &perlLIOInfo->perlLIOList, perlLIOInfo->nCount, void*); + perlLIOInfo->nCount = (sizeof(struct IPerlLIO)/sizeof(void*)); } if (perlDirInfo) { - Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); - perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); + Copy(&perlDir, &perlDirInfo->perlDirList, perlDirInfo->nCount, void*); + perlDirInfo->nCount = (sizeof(struct IPerlDir)/sizeof(void*)); } if (perlSockInfo) { - Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); - perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); + Copy(&perlSock, &perlSockInfo->perlSockList, perlSockInfo->nCount, void*); + perlSockInfo->nCount = (sizeof(struct IPerlSock)/sizeof(void*)); } if (perlProcInfo) { - Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); - perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); + Copy(&perlProc, &perlProcInfo->perlProcList, perlProcInfo->nCount, void*); + perlProcInfo->nCount = (sizeof(struct IPerlProc)/sizeof(void*)); } } EXTERN_C PerlInterpreter* perl_alloc_override(struct IPerlMem** ppMem, struct IPerlMem** ppMemShared, - struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, - struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, - struct IPerlDir** ppDir, struct IPerlSock** ppSock, - struct IPerlProc** ppProc) + struct IPerlMem** ppMemParse, struct IPerlEnv** ppEnv, + struct IPerlStdIO** ppStdIO, struct IPerlLIO** ppLIO, + struct IPerlDir** ppDir, struct IPerlSock** ppSock, + struct IPerlProc** ppProc) { PerlInterpreter *my_perl = NULL; CPerlHost* pHost = new CPerlHost(ppMem, ppMemShared, ppMemParse, ppEnv, - ppStdIO, ppLIO, ppDir, ppSock, ppProc); + ppStdIO, ppLIO, ppDir, ppSock, ppProc); if (pHost) { - my_perl = perl_alloc_using(pHost->m_pHostperlMem, - pHost->m_pHostperlMemShared, - pHost->m_pHostperlMemParse, - pHost->m_pHostperlEnv, - pHost->m_pHostperlStdIO, - pHost->m_pHostperlLIO, - pHost->m_pHostperlDir, - pHost->m_pHostperlSock, - pHost->m_pHostperlProc); - if (my_perl) { - w32_internal_host = pHost; - pHost->host_perl = my_perl; - } + my_perl = perl_alloc_using(pHost->m_pHostperlMem, + pHost->m_pHostperlMemShared, + pHost->m_pHostperlMemParse, + pHost->m_pHostperlEnv, + pHost->m_pHostperlStdIO, + pHost->m_pHostperlLIO, + pHost->m_pHostperlDir, + pHost->m_pHostperlSock, + pHost->m_pHostperlProc); + if (my_perl) { + w32_internal_host = pHost; + pHost->host_perl = my_perl; + } } return my_perl; } @@ -140,19 +140,19 @@ perl_alloc(void) PerlInterpreter* my_perl = NULL; CPerlHost* pHost = new CPerlHost(); if (pHost) { - my_perl = perl_alloc_using(pHost->m_pHostperlMem, - pHost->m_pHostperlMemShared, - pHost->m_pHostperlMemParse, - pHost->m_pHostperlEnv, - pHost->m_pHostperlStdIO, - pHost->m_pHostperlLIO, - pHost->m_pHostperlDir, - pHost->m_pHostperlSock, - pHost->m_pHostperlProc); - if (my_perl) { - w32_internal_host = pHost; + my_perl = perl_alloc_using(pHost->m_pHostperlMem, + pHost->m_pHostperlMemShared, + pHost->m_pHostperlMemParse, + pHost->m_pHostperlEnv, + pHost->m_pHostperlStdIO, + pHost->m_pHostperlLIO, + pHost->m_pHostperlDir, + pHost->m_pHostperlSock, + pHost->m_pHostperlProc); + if (my_perl) { + w32_internal_host = pHost; pHost->host_perl = my_perl; - } + } } return my_perl; } @@ -178,7 +178,7 @@ RunPerl(int argc, char **argv, char **env) PERL_SYS_INIT(&argc,&argv); if (!(my_perl = perl_alloc())) - return (1); + return (1); perl_construct(my_perl); PL_perl_destruct_level = 0; @@ -194,11 +194,11 @@ RunPerl(int argc, char **argv, char **env) if (!perl_parse(my_perl, xs_init, argc, argv, env)) { #if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */ - new_perl = perl_clone(my_perl, 1); - (void) perl_run(new_perl); - PERL_SET_THX(my_perl); + new_perl = perl_clone(my_perl, 1); + (void) perl_run(new_perl); + PERL_SET_THX(my_perl); #else - (void) perl_run(my_perl); + (void) perl_run(my_perl); #endif } @@ -206,9 +206,9 @@ RunPerl(int argc, char **argv, char **env) perl_free(my_perl); #ifdef USE_ITHREADS if (new_perl) { - PERL_SET_THX(new_perl); - exitstatus = perl_destruct(new_perl); - perl_free(new_perl); + PERL_SET_THX(new_perl); + exitstatus = perl_destruct(new_perl); + perl_free(new_perl); } #endif @@ -229,23 +229,23 @@ EXTERN_C /* GCC in C++ mode mangles the name, otherwise */ #endif BOOL APIENTRY DllMain(HINSTANCE hModule, /* DLL module handle */ - DWORD fdwReason, /* reason called */ - LPVOID lpvReserved) /* reserved */ + DWORD fdwReason, /* reason called */ + LPVOID lpvReserved) /* reserved */ { switch (fdwReason) { - /* The DLL is attaching to a process due to process - * initialization or a call to LoadLibrary. - */ + /* The DLL is attaching to a process due to process + * initialization or a call to LoadLibrary. + */ case DLL_PROCESS_ATTACH: - DisableThreadLibraryCalls((HMODULE)hModule); + DisableThreadLibraryCalls((HMODULE)hModule); - w32_perldll_handle = hModule; - set_w32_module_name(); - break; + w32_perldll_handle = hModule; + set_w32_module_name(); + break; - /* The DLL is detaching from a process due to - * process termination or call to FreeLibrary. - */ + /* The DLL is detaching from a process due to + * process termination or call to FreeLibrary. + */ case DLL_PROCESS_DETACH: /* As long as we use TerminateProcess()/TerminateThread() etc. for mimicing kill() anything here had better be harmless if: @@ -253,23 +253,23 @@ DllMain(HINSTANCE hModule, /* DLL module handle */ B. Called after memory allocation for Heap has been forcibly removed by OS. PerlIO_cleanup() was done here but fails (B). */ - EndSockets(); + EndSockets(); #if defined(USE_ITHREADS) - if (PL_curinterp) - FREE_THREAD_KEY; + if (PL_curinterp) + FREE_THREAD_KEY; #endif - break; + break; - /* The attached process creates a new thread. */ + /* The attached process creates a new thread. */ case DLL_THREAD_ATTACH: - break; + break; - /* The thread of the attached process terminates. */ + /* The thread of the attached process terminates. */ case DLL_THREAD_DETACH: - break; + break; default: - break; + break; } return TRUE; } @@ -295,6 +295,6 @@ perl_clone_host(PerlInterpreter* proto_perl, UV flags) { proto_perl->Isys_intern.internal_host = h; h->host_perl = proto_perl; return proto_perl; - + } #endif diff --git a/win32/vdir.h b/win32/vdir.h index c21ec7c400..f06830af41 100644 --- a/win32/vdir.h +++ b/win32/vdir.h @@ -34,25 +34,25 @@ public: inline char* GetCurrentDirectoryA(int dwBufSize, char *lpBuffer) { - char* ptr = dirTableA[nDefault]; - while (--dwBufSize) - { - if ((*lpBuffer++ = *ptr++) == '\0') - break; - } + char* ptr = dirTableA[nDefault]; + while (--dwBufSize) + { + if ((*lpBuffer++ = *ptr++) == '\0') + break; + } *lpBuffer = '\0'; - return /* unused */ NULL; + return /* unused */ NULL; }; inline WCHAR* GetCurrentDirectoryW(int dwBufSize, WCHAR *lpBuffer) { - WCHAR* ptr = dirTableW[nDefault]; - while (--dwBufSize) - { - if ((*lpBuffer++ = *ptr++) == '\0') - break; - } + WCHAR* ptr = dirTableW[nDefault]; + while (--dwBufSize) + { + if ((*lpBuffer++ = *ptr++) == '\0') + break; + } *lpBuffer = '\0'; - return /* unused */ NULL; + return /* unused */ NULL; }; DWORD CalculateEnvironmentSpace(void); @@ -66,54 +66,54 @@ protected: inline const char *GetDefaultDirA(void) { - return dirTableA[nDefault]; + return dirTableA[nDefault]; }; inline void SetDefaultDirA(char const *pPath, int index) { - SetDirA(pPath, index); - nDefault = index; + SetDirA(pPath, index); + nDefault = index; }; inline const WCHAR *GetDefaultDirW(void) { - return dirTableW[nDefault]; + return dirTableW[nDefault]; }; inline void SetDefaultDirW(WCHAR const *pPath, int index) { - SetDirW(pPath, index); - nDefault = index; + SetDirW(pPath, index); + nDefault = index; }; inline const char *GetDirA(int index) { - char *ptr = dirTableA[index]; - if (!ptr) { - /* simulate the existence of this drive */ - ptr = szLocalBufferA; - ptr[0] = 'A' + index; - ptr[1] = ':'; - ptr[2] = '\\'; - ptr[3] = 0; - } - return ptr; + char *ptr = dirTableA[index]; + if (!ptr) { + /* simulate the existence of this drive */ + ptr = szLocalBufferA; + ptr[0] = 'A' + index; + ptr[1] = ':'; + ptr[2] = '\\'; + ptr[3] = 0; + } + return ptr; }; inline const WCHAR *GetDirW(int index) { - WCHAR *ptr = dirTableW[index]; - if (!ptr) { - /* simulate the existence of this drive */ - ptr = szLocalBufferW; - ptr[0] = 'A' + index; - ptr[1] = ':'; - ptr[2] = '\\'; - ptr[3] = 0; - } - return ptr; + WCHAR *ptr = dirTableW[index]; + if (!ptr) { + /* simulate the existence of this drive */ + ptr = szLocalBufferW; + ptr[0] = 'A' + index; + ptr[1] = ':'; + ptr[2] = '\\'; + ptr[3] = 0; + } + return ptr; }; inline int DriveIndex(char chr) { - if (chr == '\\' || chr == '/') - return ('Z'-'A')+1; - return (chr | 0x20)-'a'; + if (chr == '\\' || chr == '/') + return ('Z'-'A')+1; + return (chr | 0x20)-'a'; }; VMem *pMem; @@ -139,16 +139,16 @@ void VDir::Init(VDir* pDir, VMem *p) pMem = p; if (pDir) { - for (index = 0; index < driveCount; ++index) { - SetDirW(pDir->GetDirW(index), index); - } - nDefault = pDir->GetDefault(); + for (index = 0; index < driveCount; ++index) { + SetDirW(pDir->GetDirW(index), index); + } + nDefault = pDir->GetDefault(); } else { - int bSave = bManageDirectory; - DWORD driveBits = GetLogicalDrives(); + int bSave = bManageDirectory; + DWORD driveBits = GetLogicalDrives(); - bManageDirectory = 0; + bManageDirectory = 0; WCHAR szBuffer[MAX_PATH*driveCount]; if (GetLogicalDriveStringsW(sizeof(szBuffer), szBuffer)) { WCHAR* pEnv = GetEnvironmentStringsW(); @@ -162,7 +162,7 @@ void VDir::Init(VDir* pDir, VMem *p) FreeEnvironmentStringsW(pEnv); } SetDefaultW(L"."); - bManageDirectory = bSave; + bManageDirectory = bSave; } } @@ -172,30 +172,30 @@ int VDir::SetDirA(char const *pPath, int index) int length = 0; WCHAR wBuffer[MAX_PATH+1]; if (index < driveCount && pPath != NULL) { - length = strlen(pPath); - pMem->Free(dirTableA[index]); - ptr = dirTableA[index] = (char*)pMem->Malloc(length+2); - if (ptr != NULL) { - strcpy(ptr, pPath); - ptr += length-1; - chr = *ptr++; - if (chr != '\\' && chr != '/') { - *ptr++ = '\\'; - *ptr = '\0'; - } - MultiByteToWideChar(CP_ACP, 0, dirTableA[index], -1, - wBuffer, (sizeof(wBuffer)/sizeof(WCHAR))); - length = wcslen(wBuffer); - pMem->Free(dirTableW[index]); - dirTableW[index] = (WCHAR*)pMem->Malloc((length+1)*2); - if (dirTableW[index] != NULL) { - wcscpy(dirTableW[index], wBuffer); - } - } + length = strlen(pPath); + pMem->Free(dirTableA[index]); + ptr = dirTableA[index] = (char*)pMem->Malloc(length+2); + if (ptr != NULL) { + strcpy(ptr, pPath); + ptr += length-1; + chr = *ptr++; + if (chr != '\\' && chr != '/') { + *ptr++ = '\\'; + *ptr = '\0'; + } + MultiByteToWideChar(CP_ACP, 0, dirTableA[index], -1, + wBuffer, (sizeof(wBuffer)/sizeof(WCHAR))); + length = wcslen(wBuffer); + pMem->Free(dirTableW[index]); + dirTableW[index] = (WCHAR*)pMem->Malloc((length+1)*2); + if (dirTableW[index] != NULL) { + wcscpy(dirTableW[index], wBuffer); + } + } } if(bManageDirectory) - ::SetCurrentDirectoryA(pPath); + ::SetCurrentDirectoryA(pPath); return length; } @@ -203,26 +203,26 @@ int VDir::SetDirA(char const *pPath, int index) void VDir::FromEnvA(char *pEnv, int index) { /* gets the directory for index from the environment variable. */ while (*pEnv != '\0') { - if ((pEnv[0] == '=') && (DriveIndex(pEnv[1]) == index) + if ((pEnv[0] == '=') && (DriveIndex(pEnv[1]) == index) && pEnv[2] == ':' && pEnv[3] == '=') { - SetDirA(&pEnv[4], index); - break; - } - else - pEnv += strlen(pEnv)+1; + SetDirA(&pEnv[4], index); + break; + } + else + pEnv += strlen(pEnv)+1; } } void VDir::FromEnvW(WCHAR *pEnv, int index) { /* gets the directory for index from the environment variable. */ while (*pEnv != '\0') { - if ((pEnv[0] == '=') && (DriveIndex((char)pEnv[1]) == index) + if ((pEnv[0] == '=') && (DriveIndex((char)pEnv[1]) == index) && pEnv[2] == ':' && pEnv[3] == '=') { - SetDirW(&pEnv[4], index); - break; - } - else - pEnv += wcslen(pEnv)+1; + SetDirW(&pEnv[4], index); + break; + } + else + pEnv += wcslen(pEnv)+1; } } @@ -233,9 +233,9 @@ void VDir::SetDefaultA(char const *pDefault) if (GetFullPathNameA(pDefault, sizeof(szBuffer), szBuffer, &pPtr)) { if (*pDefault != '.' && pPtr != NULL) - *pPtr = '\0'; + *pPtr = '\0'; - SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0])); + SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0])); } } @@ -244,31 +244,31 @@ int VDir::SetDirW(WCHAR const *pPath, int index) WCHAR chr, *ptr; int length = 0; if (index < driveCount && pPath != NULL) { - length = wcslen(pPath); - pMem->Free(dirTableW[index]); - ptr = dirTableW[index] = (WCHAR*)pMem->Malloc((length+2)*2); - if (ptr != NULL) { + length = wcslen(pPath); + pMem->Free(dirTableW[index]); + ptr = dirTableW[index] = (WCHAR*)pMem->Malloc((length+2)*2); + if (ptr != NULL) { char *ansi; - wcscpy(ptr, pPath); - ptr += length-1; - chr = *ptr++; - if (chr != '\\' && chr != '/') { - *ptr++ = '\\'; - *ptr = '\0'; - } + wcscpy(ptr, pPath); + ptr += length-1; + chr = *ptr++; + if (chr != '\\' && chr != '/') { + *ptr++ = '\\'; + *ptr = '\0'; + } ansi = win32_ansipath(dirTableW[index]); - length = strlen(ansi); - pMem->Free(dirTableA[index]); - dirTableA[index] = (char*)pMem->Malloc(length+1); - if (dirTableA[index] != NULL) { - strcpy(dirTableA[index], ansi); - } + length = strlen(ansi); + pMem->Free(dirTableA[index]); + dirTableA[index] = (char*)pMem->Malloc(length+1); + if (dirTableA[index] != NULL) { + strcpy(dirTableA[index], ansi); + } win32_free(ansi); - } + } } if(bManageDirectory) - ::SetCurrentDirectoryW(pPath); + ::SetCurrentDirectoryW(pPath); return length; } @@ -280,9 +280,9 @@ void VDir::SetDefaultW(WCHAR const *pDefault) if (GetFullPathNameW(pDefault, (sizeof(szBuffer)/sizeof(WCHAR)), szBuffer, &pPtr)) { if (*pDefault != '.' && pPtr != NULL) - *pPtr = '\0'; + *pPtr = '\0'; - SetDefaultDirW(szBuffer, DriveIndex((char)szBuffer[0])); + SetDefaultDirW(szBuffer, DriveIndex((char)szBuffer[0])); } } @@ -314,69 +314,69 @@ inline bool IsSpecialFileName(const char* pName) char ch = (pName[0] & ~0x20); switch (ch) { - case 'A': /* AUX */ - if (((pName[1] & ~0x20) == 'U') - && ((pName[2] & ~0x20) == 'X') - && !pName[3]) - return true; - break; - case 'C': /* CLOCK$, COMx, CON, CONIN$ CONOUT$ */ - ch = (pName[1] & ~0x20); - switch (ch) - { - case 'L': /* CLOCK$ */ - if (((pName[2] & ~0x20) == 'O') - && ((pName[3] & ~0x20) == 'C') - && ((pName[4] & ~0x20) == 'K') - && (pName[5] == '$') - && !pName[6]) - return true; - break; - case 'O': /* COMx, CON, CONIN$ CONOUT$ */ - if ((pName[2] & ~0x20) == 'M') { - if ( inRANGE(pName[3], '1', '9') - && !pName[4]) - return true; - } - else if ((pName[2] & ~0x20) == 'N') { - if (!pName[3]) - return true; - else if ((pName[3] & ~0x20) == 'I') { - if (((pName[4] & ~0x20) == 'N') - && (pName[5] == '$') - && !pName[6]) - return true; - } - else if ((pName[3] & ~0x20) == 'O') { - if (((pName[4] & ~0x20) == 'U') - && ((pName[5] & ~0x20) == 'T') - && (pName[6] == '$') - && !pName[7]) - return true; - } - } - break; - } - break; - case 'L': /* LPTx */ - if (((pName[1] & ~0x20) == 'U') - && ((pName[2] & ~0x20) == 'X') - && inRANGE(pName[3], '1', '9') - && !pName[4]) - return true; - break; - case 'N': /* NUL */ - if (((pName[1] & ~0x20) == 'U') - && ((pName[2] & ~0x20) == 'L') - && !pName[3]) - return true; - break; - case 'P': /* PRN */ - if (((pName[1] & ~0x20) == 'R') - && ((pName[2] & ~0x20) == 'N') - && !pName[3]) - return true; - break; + case 'A': /* AUX */ + if (((pName[1] & ~0x20) == 'U') + && ((pName[2] & ~0x20) == 'X') + && !pName[3]) + return true; + break; + case 'C': /* CLOCK$, COMx, CON, CONIN$ CONOUT$ */ + ch = (pName[1] & ~0x20); + switch (ch) + { + case 'L': /* CLOCK$ */ + if (((pName[2] & ~0x20) == 'O') + && ((pName[3] & ~0x20) == 'C') + && ((pName[4] & ~0x20) == 'K') + && (pName[5] == '$') + && !pName[6]) + return true; + break; + case 'O': /* COMx, CON, CONIN$ CONOUT$ */ + if ((pName[2] & ~0x20) == 'M') { + if ( inRANGE(pName[3], '1', '9') + && !pName[4]) + return true; + } + else if ((pName[2] & ~0x20) == 'N') { + if (!pName[3]) + return true; + else if ((pName[3] & ~0x20) == 'I') { + if (((pName[4] & ~0x20) == 'N') + && (pName[5] == '$') + && !pName[6]) + return true; + } + else if ((pName[3] & ~0x20) == 'O') { + if (((pName[4] & ~0x20) == 'U') + && ((pName[5] & ~0x20) == 'T') + && (pName[6] == '$') + && !pName[7]) + return true; + } + } + break; + } + break; + case 'L': /* LPTx */ + if (((pName[1] & ~0x20) == 'U') + && ((pName[2] & ~0x20) == 'X') + && inRANGE(pName[3], '1', '9') + && !pName[4]) + return true; + break; + case 'N': /* NUL */ + if (((pName[1] & ~0x20) == 'U') + && ((pName[2] & ~0x20) == 'L') + && !pName[3]) + return true; + break; + case 'P': /* PRN */ + if (((pName[1] & ~0x20) == 'R') + && ((pName[2] & ~0x20) == 'N') + && !pName[3]) + return true; + break; } return false; } @@ -392,66 +392,66 @@ char *VDir::MapPathA(const char *pInName) int length = strlen(pInName); if (!length) - return (char*)pInName; + return (char*)pInName; if (length > MAX_PATH) { - strncpy(szlBuf, pInName, MAX_PATH); - if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) { - /* absolute path - reduce length by 2 for drive specifier */ - szlBuf[MAX_PATH-2] = '\0'; - } - else - szlBuf[MAX_PATH] = '\0'; - pInName = szlBuf; + strncpy(szlBuf, pInName, MAX_PATH); + if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) { + /* absolute path - reduce length by 2 for drive specifier */ + szlBuf[MAX_PATH-2] = '\0'; + } + else + szlBuf[MAX_PATH] = '\0'; + pInName = szlBuf; } /* strlen(pInName) is now <= MAX_PATH */ if (length > 1 && pInName[1] == ':') { - /* has drive letter */ - if (length > 2 && IsPathSep(pInName[2])) { - /* absolute with drive letter */ - DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA); - } - else { - /* relative path with drive letter */ + /* has drive letter */ + if (length > 2 && IsPathSep(pInName[2])) { + /* absolute with drive letter */ + DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA); + } + else { + /* relative path with drive letter */ driveIndex = DriveIndex(*pInName); if (driveIndex < 0 || driveIndex >= driveLetterCount) return (char *)pInName; - strcpy(szBuffer, GetDirA(driveIndex)); - strcat(szBuffer, &pInName[2]); - if(strlen(szBuffer) > MAX_PATH) - szBuffer[MAX_PATH] = '\0'; + strcpy(szBuffer, GetDirA(driveIndex)); + strcat(szBuffer, &pInName[2]); + if(strlen(szBuffer) > MAX_PATH) + szBuffer[MAX_PATH] = '\0'; - DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA); - } + DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA); + } } else { - /* no drive letter */ - if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) { - /* UNC name */ - DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA); - } - else { - strcpy(szBuffer, GetDefaultDirA()); - if (IsPathSep(pInName[0])) { - /* absolute path */ - strcpy(&szBuffer[2], pInName); - DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA); - } - else { - /* relative path */ - if (IsSpecialFileName(pInName)) { - return (char*)pInName; - } - else { - strcat(szBuffer, pInName); - if (strlen(szBuffer) > MAX_PATH) - szBuffer[MAX_PATH] = '\0'; - - DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA); - } - } - } + /* no drive letter */ + if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) { + /* UNC name */ + DoGetFullPathNameA((char*)pInName, sizeof(szLocalBufferA), szLocalBufferA); + } + else { + strcpy(szBuffer, GetDefaultDirA()); + if (IsPathSep(pInName[0])) { + /* absolute path */ + strcpy(&szBuffer[2], pInName); + DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA); + } + else { + /* relative path */ + if (IsSpecialFileName(pInName)) { + return (char*)pInName; + } + else { + strcat(szBuffer, pInName); + if (strlen(szBuffer) > MAX_PATH) + szBuffer[MAX_PATH] = '\0'; + + DoGetFullPathNameA(szBuffer, sizeof(szLocalBufferA), szLocalBufferA); + } + } + } } return szLocalBufferA; @@ -465,17 +465,17 @@ int VDir::SetCurrentDirectoryA(char *lpBuffer) pPtr = MapPathA(lpBuffer); length = strlen(pPtr); if(length > 3 && IsPathSep(pPtr[length-1])) { - /* don't remove the trailing slash from 'x:\' */ - pPtr[length-1] = '\0'; + /* don't remove the trailing slash from 'x:\' */ + pPtr[length-1] = '\0'; } DWORD r = GetFileAttributesA(pPtr); if ((r != 0xffffffff) && (r & FILE_ATTRIBUTE_DIRECTORY)) { - char szBuffer[(MAX_PATH+1)*2]; - DoGetFullPathNameA(pPtr, sizeof(szBuffer), szBuffer); - SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0])); - nRet = 0; + char szBuffer[(MAX_PATH+1)*2]; + DoGetFullPathNameA(pPtr, sizeof(szBuffer), szBuffer); + SetDefaultDirA(szBuffer, DriveIndex(szBuffer[0])); + nRet = 0; } return nRet; @@ -486,9 +486,9 @@ DWORD VDir::CalculateEnvironmentSpace(void) int index; DWORD dwSize = 0; for (index = 0; index < driveCount; ++index) { - if (dirTableA[index] != NULL) { - dwSize += strlen(dirTableA[index]) + 5; /* add 1 for trailing NULL and 4 for '=D:=' */ - } + if (dirTableA[index] != NULL) { + dwSize += strlen(dirTableA[index]) + 5; /* add 1 for trailing NULL and 4 for '=D:=' */ + } } return dwSize; } @@ -498,22 +498,22 @@ LPSTR VDir::BuildEnvironmentSpace(LPSTR lpStr) int index, length; LPSTR lpDirStr; for (index = 0; index < driveCount; ++index) { - lpDirStr = dirTableA[index]; - if (lpDirStr != NULL) { - lpStr[0] = '='; - lpStr[1] = lpDirStr[0]; - lpStr[2] = '\0'; - CharUpper(&lpStr[1]); - lpStr[2] = ':'; - lpStr[3] = '='; - strcpy(&lpStr[4], lpDirStr); - length = strlen(lpDirStr); - lpStr += length + 5; /* add 1 for trailing NULL and 4 for '=D:=' */ - if (length > 3 && IsPathSep(lpStr[-2])) { - lpStr[-2] = '\0'; /* remove the trailing path separator */ - --lpStr; - } - } + lpDirStr = dirTableA[index]; + if (lpDirStr != NULL) { + lpStr[0] = '='; + lpStr[1] = lpDirStr[0]; + lpStr[2] = '\0'; + CharUpper(&lpStr[1]); + lpStr[2] = ':'; + lpStr[3] = '='; + strcpy(&lpStr[4], lpDirStr); + length = strlen(lpDirStr); + lpStr += length + 5; /* add 1 for trailing NULL and 4 for '=D:=' */ + if (length > 3 && IsPathSep(lpStr[-2])) { + lpStr[-2] = '\0'; /* remove the trailing path separator */ + --lpStr; + } + } } return lpStr; } @@ -546,69 +546,69 @@ inline bool IsSpecialFileName(const WCHAR* pName) WCHAR ch = (pName[0] & ~0x20); switch (ch) { - case 'A': /* AUX */ - if (((pName[1] & ~0x20) == 'U') - && ((pName[2] & ~0x20) == 'X') - && !pName[3]) - return true; - break; - case 'C': /* CLOCK$, COMx, CON, CONIN$ CONOUT$ */ - ch = (pName[1] & ~0x20); - switch (ch) - { - case 'L': /* CLOCK$ */ - if (((pName[2] & ~0x20) == 'O') - && ((pName[3] & ~0x20) == 'C') - && ((pName[4] & ~0x20) == 'K') - && (pName[5] == '$') - && !pName[6]) - return true; - break; - case 'O': /* COMx, CON, CONIN$ CONOUT$ */ - if ((pName[2] & ~0x20) == 'M') { - if ( inRANGE(pName[3], '1', '9') - && !pName[4]) - return true; - } - else if ((pName[2] & ~0x20) == 'N') { - if (!pName[3]) - return true; - else if ((pName[3] & ~0x20) == 'I') { - if (((pName[4] & ~0x20) == 'N') - && (pName[5] == '$') - && !pName[6]) - return true; - } - else if ((pName[3] & ~0x20) == 'O') { - if (((pName[4] & ~0x20) == 'U') - && ((pName[5] & ~0x20) == 'T') - && (pName[6] == '$') - && !pName[7]) - return true; - } - } - break; - } - break; - case 'L': /* LPTx */ - if (((pName[1] & ~0x20) == 'U') - && ((pName[2] & ~0x20) == 'X') - && inRANGE(pName[3], '1', '9') - && !pName[4]) - return true; - break; - case 'N': /* NUL */ - if (((pName[1] & ~0x20) == 'U') - && ((pName[2] & ~0x20) == 'L') - && !pName[3]) - return true; - break; - case 'P': /* PRN */ - if (((pName[1] & ~0x20) == 'R') - && ((pName[2] & ~0x20) == 'N') - && !pName[3]) - return true; - break; + case 'A': /* AUX */ + if (((pName[1] & ~0x20) == 'U') + && ((pName[2] & ~0x20) == 'X') + && !pName[3]) + return true; + break; + case 'C': /* CLOCK$, COMx, CON, CONIN$ CONOUT$ */ + ch = (pName[1] & ~0x20); + switch (ch) + { + case 'L': /* CLOCK$ */ + if (((pName[2] & ~0x20) == 'O') + && ((pName[3] & ~0x20) == 'C') + && ((pName[4] & ~0x20) == 'K') + && (pName[5] == '$') + && !pName[6]) + return true; + break; + case 'O': /* COMx, CON, CONIN$ CONOUT$ */ + if ((pName[2] & ~0x20) == 'M') { + if ( inRANGE(pName[3], '1', '9') + && !pName[4]) + return true; + } + else if ((pName[2] & ~0x20) == 'N') { + if (!pName[3]) + return true; + else if ((pName[3] & ~0x20) == 'I') { + if (((pName[4] & ~0x20) == 'N') + && (pName[5] == '$') + && !pName[6]) + return true; + } + else if ((pName[3] & ~0x20) == 'O') { + if (((pName[4] & ~0x20) == 'U') + && ((pName[5] & ~0x20) == 'T') + && (pName[6] == '$') + && !pName[7]) + return true; + } + } + break; + } + break; + case 'L': /* LPTx */ + if (((pName[1] & ~0x20) == 'U') + && ((pName[2] & ~0x20) == 'X') + && inRANGE(pName[3], '1', '9') + && !pName[4]) + return true; + break; + case 'N': /* NUL */ + if (((pName[1] & ~0x20) == 'U') + && ((pName[2] & ~0x20) == 'L') + && !pName[3]) + return true; + break; + case 'P': /* PRN */ + if (((pName[1] & ~0x20) == 'R') + && ((pName[2] & ~0x20) == 'N') + && !pName[3]) + return true; + break; } return false; } @@ -624,66 +624,66 @@ WCHAR* VDir::MapPathW(const WCHAR *pInName) int length = wcslen(pInName); if (!length) - return (WCHAR*)pInName; + return (WCHAR*)pInName; if (length > MAX_PATH) { - wcsncpy(szlBuf, pInName, MAX_PATH); - if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) { - /* absolute path - reduce length by 2 for drive specifier */ - szlBuf[MAX_PATH-2] = '\0'; - } - else - szlBuf[MAX_PATH] = '\0'; - pInName = szlBuf; + wcsncpy(szlBuf, pInName, MAX_PATH); + if (IsPathSep(pInName[0]) && !IsPathSep(pInName[1])) { + /* absolute path - reduce length by 2 for drive specifier */ + szlBuf[MAX_PATH-2] = '\0'; + } + else + szlBuf[MAX_PATH] = '\0'; + pInName = szlBuf; } /* strlen(pInName) is now <= MAX_PATH */ if (length > 1 && pInName[1] == ':') { - /* has drive letter */ - if (IsPathSep(pInName[2])) { - /* absolute with drive letter */ - DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); - } - else { - /* relative path with drive letter */ + /* has drive letter */ + if (IsPathSep(pInName[2])) { + /* absolute with drive letter */ + DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); + } + else { + /* relative path with drive letter */ driveIndex = DriveIndex(*pInName); if (driveIndex < 0 || driveIndex >= driveLetterCount) return (WCHAR *)pInName; - wcscpy(szBuffer, GetDirW(driveIndex)); - wcscat(szBuffer, &pInName[2]); - if(wcslen(szBuffer) > MAX_PATH) - szBuffer[MAX_PATH] = '\0'; + wcscpy(szBuffer, GetDirW(driveIndex)); + wcscat(szBuffer, &pInName[2]); + if(wcslen(szBuffer) > MAX_PATH) + szBuffer[MAX_PATH] = '\0'; - DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); - } + DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); + } } else { - /* no drive letter */ - if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) { - /* UNC name */ - DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); - } - else { - wcscpy(szBuffer, GetDefaultDirW()); - if (IsPathSep(pInName[0])) { - /* absolute path */ - wcscpy(&szBuffer[2], pInName); - DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); - } - else { - /* relative path */ - if (IsSpecialFileName(pInName)) { - return (WCHAR*)pInName; - } - else { - wcscat(szBuffer, pInName); - if (wcslen(szBuffer) > MAX_PATH) - szBuffer[MAX_PATH] = '\0'; - - DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); - } - } - } + /* no drive letter */ + if (length > 1 && IsPathSep(pInName[1]) && IsPathSep(pInName[0])) { + /* UNC name */ + DoGetFullPathNameW((WCHAR*)pInName, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); + } + else { + wcscpy(szBuffer, GetDefaultDirW()); + if (IsPathSep(pInName[0])) { + /* absolute path */ + wcscpy(&szBuffer[2], pInName); + DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); + } + else { + /* relative path */ + if (IsSpecialFileName(pInName)) { + return (WCHAR*)pInName; + } + else { + wcscat(szBuffer, pInName); + if (wcslen(szBuffer) > MAX_PATH) + szBuffer[MAX_PATH] = '\0'; + + DoGetFullPathNameW(szBuffer, (sizeof(szLocalBufferW)/sizeof(WCHAR)), szLocalBufferW); + } + } + } } return szLocalBufferW; } @@ -696,17 +696,17 @@ int VDir::SetCurrentDirectoryW(WCHAR *lpBuffer) pPtr = MapPathW(lpBuffer); length = wcslen(pPtr); if(length > 3 && IsPathSep(pPtr[length-1])) { - /* don't remove the trailing slash from 'x:\' */ - pPtr[length-1] = '\0'; + /* don't remove the trailing slash from 'x:\' */ + pPtr[length-1] = '\0'; } DWORD r = GetFileAttributesW(pPtr); if ((r != 0xffffffff) && (r & FILE_ATTRIBUTE_DIRECTORY)) { - WCHAR wBuffer[(MAX_PATH+1)*2]; - DoGetFullPathNameW(pPtr, (sizeof(wBuffer)/sizeof(WCHAR)), wBuffer); - SetDefaultDirW(wBuffer, DriveIndex((char)wBuffer[0])); - nRet = 0; + WCHAR wBuffer[(MAX_PATH+1)*2]; + DoGetFullPathNameW(pPtr, (sizeof(wBuffer)/sizeof(WCHAR)), wBuffer); + SetDefaultDirW(wBuffer, DriveIndex((char)wBuffer[0])); + nRet = 0; } return nRet; diff --git a/win32/vmem.h b/win32/vmem.h index 3fd7e169fc..bd765f68e2 100644 --- a/win32/vmem.h +++ b/win32/vmem.h @@ -93,26 +93,26 @@ public: inline BOOL CreateOk(void) { - return TRUE; + return TRUE; }; protected: #ifdef _USE_LINKED_LIST void LinkBlock(PMEMORY_BLOCK_HEADER ptr) { - PMEMORY_BLOCK_HEADER next = m_Dummy.pNext; - m_Dummy.pNext = ptr; - ptr->pPrev = &m_Dummy; - ptr->pNext = next; + PMEMORY_BLOCK_HEADER next = m_Dummy.pNext; + m_Dummy.pNext = ptr; + ptr->pPrev = &m_Dummy; + ptr->pNext = next; ptr->owner = this; - next->pPrev = ptr; + next->pPrev = ptr; } void UnlinkBlock(PMEMORY_BLOCK_HEADER ptr) { - PMEMORY_BLOCK_HEADER next = ptr->pNext; - PMEMORY_BLOCK_HEADER prev = ptr->pPrev; - prev->pNext = next; - next->pPrev = prev; + PMEMORY_BLOCK_HEADER next = ptr->pNext; + PMEMORY_BLOCK_HEADER prev = ptr->pPrev; + prev->pNext = next; + next->pPrev = prev; } MEMORY_BLOCK_HEADER m_Dummy; @@ -136,7 +136,7 @@ VMem::~VMem(void) { #ifdef _USE_LINKED_LIST while (m_Dummy.pNext != &m_Dummy) { - Free(m_Dummy.pNext+1); + Free(m_Dummy.pNext+1); } DeleteCriticalSection(&m_cs); #endif @@ -148,8 +148,8 @@ void* VMem::Malloc(size_t size) GetLock(); PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)malloc(size+sizeof(MEMORY_BLOCK_HEADER)); if (!ptr) { - FreeLock(); - return NULL; + FreeLock(); + return NULL; } LinkBlock(ptr); FreeLock(); @@ -163,11 +163,11 @@ void* VMem::Realloc(void* pMem, size_t size) { #ifdef _USE_LINKED_LIST if (!pMem) - return Malloc(size); + return Malloc(size); if (!size) { - Free(pMem); - return NULL; + Free(pMem); + return NULL; } GetLock(); @@ -175,8 +175,8 @@ void* VMem::Realloc(void* pMem, size_t size) UnlinkBlock(ptr); ptr = (PMEMORY_BLOCK_HEADER)realloc(ptr, size+sizeof(MEMORY_BLOCK_HEADER)); if (!ptr) { - FreeLock(); - return NULL; + FreeLock(); + return NULL; } LinkBlock(ptr); FreeLock(); @@ -191,25 +191,25 @@ void VMem::Free(void* pMem) { #ifdef _USE_LINKED_LIST if (pMem) { - PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)(((char*)pMem)-sizeof(MEMORY_BLOCK_HEADER)); + PMEMORY_BLOCK_HEADER ptr = (PMEMORY_BLOCK_HEADER)(((char*)pMem)-sizeof(MEMORY_BLOCK_HEADER)); if (ptr->owner != this) { - if (ptr->owner) { + if (ptr->owner) { #if 1 - int *nowhere = NULL; - Perl_warn_nocontext("Free to wrong pool %p not %p",this,ptr->owner); - *nowhere = 0; /* this segfault is deliberate, - so you can see the stack trace */ + int *nowhere = NULL; + Perl_warn_nocontext("Free to wrong pool %p not %p",this,ptr->owner); + *nowhere = 0; /* this segfault is deliberate, + so you can see the stack trace */ #else ptr->owner->Free(pMem); #endif - } - return; + } + return; } - GetLock(); - UnlinkBlock(ptr); - ptr->owner = NULL; - free(ptr); - FreeLock(); + GetLock(); + UnlinkBlock(ptr); + ptr->owner = NULL; + free(ptr); + FreeLock(); } #else /*_USE_LINKED_LIST*/ free(pMem); @@ -238,7 +238,7 @@ int VMem::IsLocked(void) * skirt the issue for now. */ BOOL bAccessed = TryEnterCriticalSection(&m_cs); if(bAccessed) { - LeaveCriticalSection(&m_cs); + LeaveCriticalSection(&m_cs); } return !bAccessed; #else @@ -251,7 +251,7 @@ long VMem::Release(void) { long lCount = InterlockedDecrement(&m_lRefCount); if(!lCount) - delete this; + delete this; return lCount; } @@ -411,9 +411,9 @@ public: inline BOOL CreateOk(void) { #ifdef _USE_BUDDY_BLOCKS - return TRUE; + return TRUE; #else - return m_hHeap != NULL; + return m_hHeap != NULL; #endif }; @@ -425,7 +425,7 @@ protected: int HeapAdd(void* ptr, size_t size #ifdef USE_BIGBLOCK_ALLOC - , BOOL bBigBlock + , BOOL bBigBlock #endif ); @@ -434,35 +434,35 @@ protected: #ifdef _USE_BUDDY_BLOCKS inline PBLOCK GetFreeListLink(int index) { - if (index >= nListEntries) - index = nListEntries-1; - return &m_FreeList[index].Dummy[sizeofTag]; + if (index >= nListEntries) + index = nListEntries-1; + return &m_FreeList[index].Dummy[sizeofTag]; } inline PBLOCK GetOverSizeFreeList(void) { - return &m_FreeList[nListEntries-1].Dummy[sizeofTag]; + return &m_FreeList[nListEntries-1].Dummy[sizeofTag]; } inline PBLOCK GetEOLFreeList(void) { - return &m_FreeList[nListEntries].Dummy[sizeofTag]; + return &m_FreeList[nListEntries].Dummy[sizeofTag]; } void AddToFreeList(PBLOCK block, size_t size) { - PBLOCK pFreeList = GetFreeListLink(CalcEntry(size)); - PBLOCK next = NEXT(pFreeList); - NEXT(pFreeList) = block; - SetLink(block, pFreeList, next); - PREV(next) = block; + PBLOCK pFreeList = GetFreeListLink(CalcEntry(size)); + PBLOCK next = NEXT(pFreeList); + NEXT(pFreeList) = block; + SetLink(block, pFreeList, next); + PREV(next) = block; } #endif inline size_t CalcAllocSize(size_t size) { - /* - * Adjust the real size of the block to be a multiple of sizeof(long), and add - * the overhead for the boundary tags. Disallow negative or zero sizes. - */ - return (size < minBlockSize) ? minAllocSize : (size_t)ROUND_UP(size) + blockOverhead; + /* + * Adjust the real size of the block to be a multiple of sizeof(long), and add + * the overhead for the boundary tags. Disallow negative or zero sizes. + */ + return (size < minBlockSize) ? minAllocSize : (size_t)ROUND_UP(size) + blockOverhead; } #ifdef _USE_BUDDY_BLOCKS @@ -491,8 +491,8 @@ VMem::VMem() m_lRefCount = 1; #ifndef _USE_BUDDY_BLOCKS BOOL bRet = (NULL != (m_hHeap = HeapCreate(HEAP_NO_SERIALIZE, - lAllocStart, /* initial size of heap */ - 0))); /* no upper limit on size of heap */ + lAllocStart, /* initial size of heap */ + 0))); /* no upper limit on size of heap */ ASSERT(bRet); #endif @@ -514,14 +514,14 @@ VMem::~VMem(void) DeleteCriticalSection(&m_cs); #ifdef _USE_BUDDY_BLOCKS for(int index = 0; index < m_nHeaps; ++index) { - VirtualFree(m_heaps[index].base, 0, MEM_RELEASE); + VirtualFree(m_heaps[index].base, 0, MEM_RELEASE); } #else /* !_USE_BUDDY_BLOCKS */ #ifdef USE_BIGBLOCK_ALLOC for(int index = 0; index < m_nHeaps; ++index) { - if (m_heaps[index].bBigBlock) { - VirtualFree(m_heaps[index].base, 0, MEM_RELEASE); - } + if (m_heaps[index].bBigBlock) { + VirtualFree(m_heaps[index].base, 0, MEM_RELEASE); + } } #endif BOOL bRet = HeapDestroy(m_hHeap); @@ -533,15 +533,15 @@ void VMem::ReInit(void) { for(int index = 0; index < m_nHeaps; ++index) { #ifdef _USE_BUDDY_BLOCKS - VirtualFree(m_heaps[index].base, 0, MEM_RELEASE); + VirtualFree(m_heaps[index].base, 0, MEM_RELEASE); #else #ifdef USE_BIGBLOCK_ALLOC - if (m_heaps[index].bBigBlock) { - VirtualFree(m_heaps[index].base, 0, MEM_RELEASE); - } - else + if (m_heaps[index].bBigBlock) { + VirtualFree(m_heaps[index].base, 0, MEM_RELEASE); + } + else #endif - HeapFree(m_hHeap, HEAP_NO_SERIALIZE, m_heaps[index].base); + HeapFree(m_hHeap, HEAP_NO_SERIALIZE, m_heaps[index].base); #endif /* _USE_BUDDY_BLOCKS */ } @@ -559,9 +559,9 @@ void VMem::Init(void) * Set the next allocation size. */ for (int index = 0; index < nListEntries; ++index) { - pFreeList = GetFreeListLink(index); - SIZE(pFreeList) = PSIZE(pFreeList+minAllocSize) = 0; - PREV(pFreeList) = NEXT(pFreeList) = pFreeList; + pFreeList = GetFreeListLink(index); + SIZE(pFreeList) = PSIZE(pFreeList+minAllocSize) = 0; + PREV(pFreeList) = NEXT(pFreeList) = pFreeList; } pFreeList = GetEOLFreeList(); SIZE(pFreeList) = PSIZE(pFreeList+minAllocSize) = 0; @@ -592,7 +592,7 @@ void* VMem::Malloc(size_t size) */ size_t realsize = CalcAllocSize(size); if((int)realsize < minAllocSize || size == 0) - return NULL; + return NULL; #ifdef _USE_BUDDY_BLOCKS /* @@ -602,78 +602,78 @@ void* VMem::Malloc(size_t size) * split the block if needed, stop at end of list marker */ { - int index = CalcEntry(realsize); - if (index < nListEntries-1) { - ptr = GetFreeListLink(index); - lsize = SIZE(ptr); - if (lsize >= realsize) { - rem = lsize - realsize; - if(rem < minAllocSize) { - /* Unlink the block from the free list. */ - Unlink(ptr); - } - else { - /* - * split the block - * The remainder is big enough to split off into a new block. - * Use the end of the block, resize the beginning of the block - * no need to change the free list. - */ - SetTags(ptr, rem); - ptr += SIZE(ptr); - lsize = realsize; - } - SetTags(ptr, lsize | 1); - return ptr; - } - ptr = m_pRover; - lsize = SIZE(ptr); - if (lsize >= realsize) { - rem = lsize - realsize; - if(rem < minAllocSize) { - /* Unlink the block from the free list. */ - Unlink(ptr); - } - else { - /* - * split the block - * The remainder is big enough to split off into a new block. - * Use the end of the block, resize the beginning of the block - * no need to change the free list. - */ - SetTags(ptr, rem); - ptr += SIZE(ptr); - lsize = realsize; - } - SetTags(ptr, lsize | 1); - return ptr; - } - ptr = GetFreeListLink(index+1); - while (NEXT(ptr)) { - lsize = SIZE(ptr); - if (lsize >= realsize) { - size_t rem = lsize - realsize; - if(rem < minAllocSize) { - /* Unlink the block from the free list. */ - Unlink(ptr); - } - else { - /* - * split the block - * The remainder is big enough to split off into a new block. - * Use the end of the block, resize the beginning of the block - * no need to change the free list. - */ - SetTags(ptr, rem); - ptr += SIZE(ptr); - lsize = realsize; - } - SetTags(ptr, lsize | 1); - return ptr; - } - ptr += sizeof(FREE_LIST_ENTRY); - } - } + int index = CalcEntry(realsize); + if (index < nListEntries-1) { + ptr = GetFreeListLink(index); + lsize = SIZE(ptr); + if (lsize >= realsize) { + rem = lsize - realsize; + if(rem < minAllocSize) { + /* Unlink the block from the free list. */ + Unlink(ptr); + } + else { + /* + * split the block + * The remainder is big enough to split off into a new block. + * Use the end of the block, resize the beginning of the block + * no need to change the free list. + */ + SetTags(ptr, rem); + ptr += SIZE(ptr); + lsize = realsize; + } + SetTags(ptr, lsize | 1); + return ptr; + } + ptr = m_pRover; + lsize = SIZE(ptr); + if (lsize >= realsize) { + rem = lsize - realsize; + if(rem < minAllocSize) { + /* Unlink the block from the free list. */ + Unlink(ptr); + } + else { + /* + * split the block + * The remainder is big enough to split off into a new block. + * Use the end of the block, resize the beginning of the block + * no need to change the free list. + */ + SetTags(ptr, rem); + ptr += SIZE(ptr); + lsize = realsize; + } + SetTags(ptr, lsize | 1); + return ptr; + } + ptr = GetFreeListLink(index+1); + while (NEXT(ptr)) { + lsize = SIZE(ptr); + if (lsize >= realsize) { + size_t rem = lsize - realsize; + if(rem < minAllocSize) { + /* Unlink the block from the free list. */ + Unlink(ptr); + } + else { + /* + * split the block + * The remainder is big enough to split off into a new block. + * Use the end of the block, resize the beginning of the block + * no need to change the free list. + */ + SetTags(ptr, rem); + ptr += SIZE(ptr); + lsize = realsize; + } + SetTags(ptr, lsize | 1); + return ptr; + } + ptr += sizeof(FREE_LIST_ENTRY); + } + } } #endif @@ -684,46 +684,46 @@ void* VMem::Malloc(size_t size) ptr = m_pRover; /* start searching at rover */ int loops = 2; /* allow two times through the loop */ for(;;) { - lsize = SIZE(ptr); - ASSERT((lsize&1)==0); - /* is block big enough? */ - if(lsize >= realsize) { - /* if the remainder is too small, don't bother splitting the block. */ - rem = lsize - realsize; - if(rem < minAllocSize) { - if(m_pRover == ptr) - m_pRover = NEXT(ptr); - - /* Unlink the block from the free list. */ - Unlink(ptr); - } - else { - /* - * split the block - * The remainder is big enough to split off into a new block. - * Use the end of the block, resize the beginning of the block - * no need to change the free list. - */ - SetTags(ptr, rem); - ptr += SIZE(ptr); - lsize = realsize; - } - /* Set the boundary tags to mark it as allocated. */ - SetTags(ptr, lsize | 1); - return ((void *)ptr); - } - - /* - * This block was unsuitable. If we've gone through this list once already without - * finding anything, allocate some new memory from the heap and try again. - */ - ptr = NEXT(ptr); - if(ptr == m_pRover) { - if(!(loops-- && Getmem(realsize))) { - return NULL; - } - ptr = m_pRover; - } + lsize = SIZE(ptr); + ASSERT((lsize&1)==0); + /* is block big enough? */ + if(lsize >= realsize) { + /* if the remainder is too small, don't bother splitting the block. */ + rem = lsize - realsize; + if(rem < minAllocSize) { + if(m_pRover == ptr) + m_pRover = NEXT(ptr); + + /* Unlink the block from the free list. */ + Unlink(ptr); + } + else { + /* + * split the block + * The remainder is big enough to split off into a new block. + * Use the end of the block, resize the beginning of the block + * no need to change the free list. + */ + SetTags(ptr, rem); + ptr += SIZE(ptr); + lsize = realsize; + } + /* Set the boundary tags to mark it as allocated. */ + SetTags(ptr, lsize | 1); + return ((void *)ptr); + } + + /* + * This block was unsuitable. If we've gone through this list once already without + * finding anything, allocate some new memory from the heap and try again. + */ + ptr = NEXT(ptr); + if(ptr == m_pRover) { + if(!(loops-- && Getmem(realsize))) { + return NULL; + } + ptr = m_pRover; + } } } @@ -733,24 +733,24 @@ void* VMem::Realloc(void* block, size_t size) /* if size is zero, free the block. */ if(size == 0) { - Free(block); - return (NULL); + Free(block); + return (NULL); } /* if block pointer is NULL, do a Malloc(). */ if(block == NULL) - return Malloc(size); + return Malloc(size); /* * Grow or shrink the block in place. * if the block grows then the next block will be used if free */ if(Expand(block, size) != NULL) - return block; + return block; size_t realsize = CalcAllocSize(size); if((int)realsize < minAllocSize) - return NULL; + return NULL; /* * see if the previous block is free, and is it big enough to cover the new size @@ -760,46 +760,46 @@ void* VMem::Realloc(void* block, size_t size) size_t cursize = SIZE(ptr) & ~1; size_t psize = PSIZE(ptr); if((psize&1) == 0 && (psize + cursize) >= realsize) { - PBLOCK prev = ptr - psize; - if(m_pRover == prev) - m_pRover = NEXT(prev); - - /* Unlink the next block from the free list. */ - Unlink(prev); - - /* Copy contents of old block to new location, make it the current block. */ - memmove(prev, ptr, cursize); - cursize += psize; /* combine sizes */ - ptr = prev; - - size_t rem = cursize - realsize; - if(rem >= minAllocSize) { - /* - * The remainder is big enough to be a new block. Set boundary - * tags for the resized block and the new block. - */ - prev = ptr + realsize; - /* - * add the new block to the free list. - * next block cannot be free - */ - SetTags(prev, rem); + PBLOCK prev = ptr - psize; + if(m_pRover == prev) + m_pRover = NEXT(prev); + + /* Unlink the next block from the free list. */ + Unlink(prev); + + /* Copy contents of old block to new location, make it the current block. */ + memmove(prev, ptr, cursize); + cursize += psize; /* combine sizes */ + ptr = prev; + + size_t rem = cursize - realsize; + if(rem >= minAllocSize) { + /* + * The remainder is big enough to be a new block. Set boundary + * tags for the resized block and the new block. + */ + prev = ptr + realsize; + /* + * add the new block to the free list. + * next block cannot be free + */ + SetTags(prev, rem); #ifdef _USE_BUDDY_BLOCKS - AddToFreeList(prev, rem); + AddToFreeList(prev, rem); #else - AddToFreeList(prev, m_pFreeList); + AddToFreeList(prev, m_pFreeList); #endif - cursize = realsize; + cursize = realsize; } - /* Set the boundary tags to mark it as allocated. */ - SetTags(ptr, cursize | 1); + /* Set the boundary tags to mark it as allocated. */ + SetTags(ptr, cursize | 1); return ((void *)ptr); } /* Allocate a new block, copy the old to the new, and free the old. */ if((ptr = (PBLOCK)Malloc(size)) != NULL) { - memmove(ptr, block, cursize-blockOverhead); - Free(block); + memmove(ptr, block, cursize-blockOverhead); + Free(block); } return ((void *)ptr); } @@ -810,15 +810,15 @@ void VMem::Free(void* p) /* Ignore null pointer. */ if(p == NULL) - return; + return; PBLOCK ptr = (PBLOCK)p; /* Check for attempt to free a block that's already free. */ size_t size = SIZE(ptr); if((size&1) == 0) { - MEMODSlx("Attempt to free previously freed block", (long)p); - return; + MEMODSlx("Attempt to free previously freed block", (long)p); + return; } size &= ~1; /* remove allocated tag */ @@ -828,12 +828,12 @@ void VMem::Free(void* p) #endif size_t psize = PSIZE(ptr); if((psize&1) == 0) { - ptr -= psize; /* point to previous block */ - size += psize; /* merge the sizes of the two blocks */ + ptr -= psize; /* point to previous block */ + size += psize; /* merge the sizes of the two blocks */ #ifdef _USE_BUDDY_BLOCKS - Unlink(ptr); + Unlink(ptr); #else - linked = TRUE; /* it's already on the free list */ + linked = TRUE; /* it's already on the free list */ #endif } @@ -841,15 +841,15 @@ void VMem::Free(void* p) PBLOCK next = ptr + size; /* point to next physical block */ size_t nsize = SIZE(next); if((nsize&1) == 0) { - /* block is free move rover if needed */ - if(m_pRover == next) - m_pRover = NEXT(next); + /* block is free move rover if needed */ + if(m_pRover == next) + m_pRover = NEXT(next); - /* unlink the next block from the free list. */ - Unlink(next); + /* unlink the next block from the free list. */ + Unlink(next); - /* merge the sizes of this block and the next block. */ - size += nsize; + /* merge the sizes of this block and the next block. */ + size += nsize; } /* Set the boundary tags for the block; */ @@ -857,10 +857,10 @@ void VMem::Free(void* p) /* Link the block to the head of the free list. */ #ifdef _USE_BUDDY_BLOCKS - AddToFreeList(ptr, size); + AddToFreeList(ptr, size); #else if(!linked) { - AddToFreeList(ptr, m_pFreeList); + AddToFreeList(ptr, m_pFreeList); } #endif } @@ -883,7 +883,7 @@ int VMem::IsLocked(void) * skirt the issue for now. */ BOOL bAccessed = TryEnterCriticalSection(&m_cs); if(bAccessed) { - LeaveCriticalSection(&m_cs); + LeaveCriticalSection(&m_cs); } return !bAccessed; #else @@ -897,7 +897,7 @@ long VMem::Release(void) { long lCount = InterlockedDecrement(&m_lRefCount); if(!lCount) - delete this; + delete this; return lCount; } @@ -923,30 +923,30 @@ int VMem::Getmem(size_t requestSize) * adjust up */ if(size < (unsigned long)m_lAllocSize) - size = m_lAllocSize; + size = m_lAllocSize; /* Update the size to allocate on the next request */ if(m_lAllocSize != lAllocMax) - m_lAllocSize <<= 2; + m_lAllocSize <<= 2; #ifndef _USE_BUDDY_BLOCKS if(m_nHeaps != 0 #ifdef USE_BIGBLOCK_ALLOC - && !m_heaps[m_nHeaps-1].bBigBlock + && !m_heaps[m_nHeaps-1].bBigBlock #endif - ) { - /* Expand the last allocated heap */ - ptr = HeapReAlloc(m_hHeap, HEAP_REALLOC_IN_PLACE_ONLY|HEAP_NO_SERIALIZE, - m_heaps[m_nHeaps-1].base, - m_heaps[m_nHeaps-1].len + size); - if(ptr != 0) { - HeapAdd(((char*)ptr) + m_heaps[m_nHeaps-1].len, size + ) { + /* Expand the last allocated heap */ + ptr = HeapReAlloc(m_hHeap, HEAP_REALLOC_IN_PLACE_ONLY|HEAP_NO_SERIALIZE, + m_heaps[m_nHeaps-1].base, + m_heaps[m_nHeaps-1].len + size); + if(ptr != 0) { + HeapAdd(((char*)ptr) + m_heaps[m_nHeaps-1].len, size #ifdef USE_BIGBLOCK_ALLOC - , FALSE + , FALSE #endif - ); - return -1; - } + ); + return -1; + } } #endif /* _USE_BUDDY_BLOCKS */ @@ -957,7 +957,7 @@ int VMem::Getmem(size_t requestSize) * the above ROUND_UP64K may not have added any memory to include this. */ if(size == requestSize) - size = (size_t)ROUND_UP64K(requestSize+(blockOverhead)); + size = (size_t)ROUND_UP64K(requestSize+(blockOverhead)); Restart: #ifdef _USE_BUDDY_BLOCKS @@ -966,8 +966,8 @@ Restart: #ifdef USE_BIGBLOCK_ALLOC bBigBlock = FALSE; if (size >= nMaxHeapAllocSize) { - bBigBlock = TRUE; - ptr = VirtualAlloc(NULL, size, MEM_COMMIT, PAGE_READWRITE); + bBigBlock = TRUE; + ptr = VirtualAlloc(NULL, size, MEM_COMMIT, PAGE_READWRITE); } else #endif @@ -975,28 +975,28 @@ Restart: #endif /* _USE_BUDDY_BLOCKS */ if (!ptr) { - /* try to allocate a smaller chunk */ - size >>= 1; - if(size > requestSize) - goto Restart; + /* try to allocate a smaller chunk */ + size >>= 1; + if(size > requestSize) + goto Restart; } if(ptr == 0) { - MEMODSlx("HeapAlloc failed on size!!!", size); - return 0; + MEMODSlx("HeapAlloc failed on size!!!", size); + return 0; } #ifdef _USE_BUDDY_BLOCKS if (HeapAdd(ptr, size)) { - VirtualFree(ptr, 0, MEM_RELEASE); - return 0; + VirtualFree(ptr, 0, MEM_RELEASE); + return 0; } #else #ifdef USE_BIGBLOCK_ALLOC if (HeapAdd(ptr, size, bBigBlock)) { - if (bBigBlock) { - VirtualFree(ptr, 0, MEM_RELEASE); - } + if (bBigBlock) { + VirtualFree(ptr, 0, MEM_RELEASE); + } } #else HeapAdd(ptr, size); @@ -1015,7 +1015,7 @@ int VMem::HeapAdd(void* p, size_t size /* Check size, then round size down to next long word boundary. */ if(size < minAllocSize) - return -1; + return -1; size = (size_t)ROUND_DOWN(size); PBLOCK ptr = (PBLOCK)p; @@ -1023,47 +1023,47 @@ int VMem::HeapAdd(void* p, size_t size #ifdef USE_BIGBLOCK_ALLOC if (!bBigBlock) { #endif - /* - * Search for another heap area that's contiguous with the bottom of this new area. - * (It should be extremely unusual to find one that's contiguous with the top). - */ - for(index = 0; index < m_nHeaps; ++index) { - if(ptr == m_heaps[index].base + (int)m_heaps[index].len) { - /* - * The new block is contiguous with a previously allocated heap area. Add its - * length to that of the previous heap. Merge it with the dummy end-of-heap - * area marker of the previous heap. - */ - m_heaps[index].len += size; - break; - } - } + /* + * Search for another heap area that's contiguous with the bottom of this new area. + * (It should be extremely unusual to find one that's contiguous with the top). + */ + for(index = 0; index < m_nHeaps; ++index) { + if(ptr == m_heaps[index].base + (int)m_heaps[index].len) { + /* + * The new block is contiguous with a previously allocated heap area. Add its + * length to that of the previous heap. Merge it with the dummy end-of-heap + * area marker of the previous heap. + */ + m_heaps[index].len += size; + break; + } + } #ifdef USE_BIGBLOCK_ALLOC } else { - index = m_nHeaps; + index = m_nHeaps; } #endif if(index == m_nHeaps) { - /* The new block is not contiguous, or is BigBlock. Add it to the heap list. */ - if(m_nHeaps == maxHeaps) { - return -1; /* too many non-contiguous heaps */ - } - m_heaps[m_nHeaps].base = ptr; - m_heaps[m_nHeaps].len = size; + /* The new block is not contiguous, or is BigBlock. Add it to the heap list. */ + if(m_nHeaps == maxHeaps) { + return -1; /* too many non-contiguous heaps */ + } + m_heaps[m_nHeaps].base = ptr; + m_heaps[m_nHeaps].len = size; #ifdef USE_BIGBLOCK_ALLOC - m_heaps[m_nHeaps].bBigBlock = bBigBlock; + m_heaps[m_nHeaps].bBigBlock = bBigBlock; #endif - m_nHeaps++; - - /* - * Reserve the first LONG in the block for the ending boundary tag of a dummy - * block at the start of the heap area. - */ - size -= blockOverhead; - ptr += blockOverhead; - PSIZE(ptr) = 1; /* mark the dummy previous block as allocated */ + m_nHeaps++; + + /* + * Reserve the first LONG in the block for the ending boundary tag of a dummy + * block at the start of the heap area. + */ + size -= blockOverhead; + ptr += blockOverhead; + PSIZE(ptr) = 1; /* mark the dummy previous block as allocated */ } /* @@ -1091,36 +1091,36 @@ void* VMem::Expand(void* block, size_t size) */ size_t realsize = CalcAllocSize(size); if((int)realsize < minAllocSize || size == 0) - return NULL; + return NULL; PBLOCK ptr = (PBLOCK)block; /* if the current size is the same as requested, do nothing. */ size_t cursize = SIZE(ptr) & ~1; if(cursize == realsize) { - return block; + return block; } /* if the block is being shrunk, convert the remainder of the block into a new free block. */ if(realsize <= cursize) { - size_t nextsize = cursize - realsize; /* size of new remainder block */ - if(nextsize >= minAllocSize) { - /* - * Split the block - * Set boundary tags for the resized block and the new block. - */ - SetTags(ptr, realsize | 1); - ptr += realsize; - - /* - * add the new block to the free list. - * call Free to merge this block with next block if free - */ - SetTags(ptr, nextsize | 1); - Free(ptr); - } - - return block; + size_t nextsize = cursize - realsize; /* size of new remainder block */ + if(nextsize >= minAllocSize) { + /* + * Split the block + * Set boundary tags for the resized block and the new block. + */ + SetTags(ptr, realsize | 1); + ptr += realsize; + + /* + * add the new block to the free list. + * call Free to merge this block with next block if free + */ + SetTags(ptr, nextsize | 1); + Free(ptr); + } + + return block; } PBLOCK next = ptr + cursize; @@ -1128,39 +1128,39 @@ void* VMem::Expand(void* block, size_t size) /* Check the next block for consistency.*/ if((nextsize&1) == 0 && (nextsize + cursize) >= realsize) { - /* - * The next block is free and big enough. Add the part that's needed - * to our block, and split the remainder off into a new block. - */ - if(m_pRover == next) - m_pRover = NEXT(next); - - /* Unlink the next block from the free list. */ - Unlink(next); - cursize += nextsize; /* combine sizes */ - - size_t rem = cursize - realsize; /* size of remainder */ - if(rem >= minAllocSize) { - /* - * The remainder is big enough to be a new block. - * Set boundary tags for the resized block and the new block. - */ - next = ptr + realsize; - /* - * add the new block to the free list. - * next block cannot be free - */ - SetTags(next, rem); + /* + * The next block is free and big enough. Add the part that's needed + * to our block, and split the remainder off into a new block. + */ + if(m_pRover == next) + m_pRover = NEXT(next); + + /* Unlink the next block from the free list. */ + Unlink(next); + cursize += nextsize; /* combine sizes */ + + size_t rem = cursize - realsize; /* size of remainder */ + if(rem >= minAllocSize) { + /* + * The remainder is big enough to be a new block. + * Set boundary tags for the resized block and the new block. + */ + next = ptr + realsize; + /* + * add the new block to the free list. + * next block cannot be free + */ + SetTags(next, rem); #ifdef _USE_BUDDY_BLOCKS - AddToFreeList(next, rem); + AddToFreeList(next, rem); #else - AddToFreeList(next, m_pFreeList); + AddToFreeList(next, m_pFreeList); #endif - cursize = realsize; + cursize = realsize; } - /* Set the boundary tags to mark it as allocated. */ - SetTags(ptr, cursize | 1); - return ((void *)ptr); + /* Set the boundary tags to mark it as allocated. */ + SetTags(ptr, cursize | 1); + return ((void *)ptr); } return NULL; } @@ -1172,70 +1172,70 @@ void VMem::MemoryUsageMessage(char *str, long x, long y, int c) { char szBuffer[512]; if(str) { - if(!m_pLog) - m_pLog = fopen(LOG_FILENAME, "w"); - sprintf(szBuffer, str, x, y, c); - fputs(szBuffer, m_pLog); + if(!m_pLog) + m_pLog = fopen(LOG_FILENAME, "w"); + sprintf(szBuffer, str, x, y, c); + fputs(szBuffer, m_pLog); } else { - if(m_pLog) { - fflush(m_pLog); - fclose(m_pLog); - m_pLog = 0; - } + if(m_pLog) { + fflush(m_pLog); + fclose(m_pLog); + m_pLog = 0; + } } } void VMem::WalkHeap(int complete) { if(complete) { - MemoryUsageMessage(NULL, 0, 0, 0); - size_t total = 0; - for(int i = 0; i < m_nHeaps; ++i) { - total += m_heaps[i].len; - } - MemoryUsageMessage("VMem heaps used %d. Total memory %08x\n", m_nHeaps, total, 0); - - /* Walk all the heaps - verify structures */ - for(int index = 0; index < m_nHeaps; ++index) { - PBLOCK ptr = m_heaps[index].base; - size_t size = m_heaps[index].len; + MemoryUsageMessage(NULL, 0, 0, 0); + size_t total = 0; + for(int i = 0; i < m_nHeaps; ++i) { + total += m_heaps[i].len; + } + MemoryUsageMessage("VMem heaps used %d. Total memory %08x\n", m_nHeaps, total, 0); + + /* Walk all the heaps - verify structures */ + for(int index = 0; index < m_nHeaps; ++index) { + PBLOCK ptr = m_heaps[index].base; + size_t size = m_heaps[index].len; #ifndef _USE_BUDDY_BLOCKS #ifdef USE_BIGBLOCK_ALLOC - if (!m_heaps[m_nHeaps].bBigBlock) + if (!m_heaps[m_nHeaps].bBigBlock) #endif - ASSERT(HeapValidate(m_hHeap, HEAP_NO_SERIALIZE, ptr)); + ASSERT(HeapValidate(m_hHeap, HEAP_NO_SERIALIZE, ptr)); #endif - /* set over reserved header block */ - size -= blockOverhead; - ptr += blockOverhead; - PBLOCK pLast = ptr + size; - ASSERT(PSIZE(ptr) == 1); /* dummy previous block is allocated */ - ASSERT(SIZE(pLast) == 1); /* dummy next block is allocated */ - while(ptr < pLast) { - ASSERT(ptr > m_heaps[index].base); - size_t cursize = SIZE(ptr) & ~1; - ASSERT((PSIZE(ptr+cursize) & ~1) == cursize); - MemoryUsageMessage("Memory Block %08x: Size %08x %c\n", (long)ptr, cursize, (SIZE(ptr)&1) ? 'x' : ' '); - if(!(SIZE(ptr)&1)) { - /* this block is on the free list */ - PBLOCK tmp = NEXT(ptr); - while(tmp != ptr) { - ASSERT((SIZE(tmp)&1)==0); - if(tmp == m_pFreeList) - break; - ASSERT(NEXT(tmp)); - tmp = NEXT(tmp); - } - if(tmp == ptr) { - MemoryUsageMessage("Memory Block %08x: Size %08x free but not in free list\n", (long)ptr, cursize, 0); - } - } - ptr += cursize; - } - } - MemoryUsageMessage(NULL, 0, 0, 0); + /* set over reserved header block */ + size -= blockOverhead; + ptr += blockOverhead; + PBLOCK pLast = ptr + size; + ASSERT(PSIZE(ptr) == 1); /* dummy previous block is allocated */ + ASSERT(SIZE(pLast) == 1); /* dummy next block is allocated */ + while(ptr < pLast) { + ASSERT(ptr > m_heaps[index].base); + size_t cursize = SIZE(ptr) & ~1; + ASSERT((PSIZE(ptr+cursize) & ~1) == cursize); + MemoryUsageMessage("Memory Block %08x: Size %08x %c\n", (long)ptr, cursize, (SIZE(ptr)&1) ? 'x' : ' '); + if(!(SIZE(ptr)&1)) { + /* this block is on the free list */ + PBLOCK tmp = NEXT(ptr); + while(tmp != ptr) { + ASSERT((SIZE(tmp)&1)==0); + if(tmp == m_pFreeList) + break; + ASSERT(NEXT(tmp)); + tmp = NEXT(tmp); + } + if(tmp == ptr) { + MemoryUsageMessage("Memory Block %08x: Size %08x free but not in free list\n", (long)ptr, cursize, 0); + } + } + ptr += cursize; + } + } + MemoryUsageMessage(NULL, 0, 0, 0); } } #endif /* _DEBUG_MEM */ diff --git a/win32/win32.c b/win32/win32.c index 9f0259a807..cdd5685c41 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -110,8 +110,8 @@ END_EXTERN_C #ifdef SET_INVALID_PARAMETER_HANDLER static BOOL set_silent_invalid_parameter_handler(BOOL newvalue); static void my_invalid_parameter_handler(const wchar_t* expression, - const wchar_t* function, const wchar_t* file, - unsigned int line, uintptr_t pReserved); + const wchar_t* function, const wchar_t* file, + unsigned int line, uintptr_t pReserved); #endif #ifndef WIN32_NO_REGISTRY @@ -120,10 +120,10 @@ static char* get_regstr(const char *valuename, SV **svp); #endif static char* get_emd_part(SV **prev_pathp, STRLEN *const len, - char *trailing, ...); + char *trailing, ...); static char* win32_get_xlib(const char *pl, - WIN32_NO_REGISTRY_M_(const char *xlib) - const char *libname, STRLEN *const len); + WIN32_NO_REGISTRY_M_(const char *xlib) + const char *libname, STRLEN *const len); static BOOL has_shell_metachars(const char *ptr); static long tokenize(const char *str, char **dest, char ***destv); @@ -135,7 +135,7 @@ static int do_spawn2_handles(pTHX_ const char *cmd, int exectype, static int do_spawnvp_handles(int mode, const char *cmdname, const char * const *argv, const int *handles); static PerlIO * do_popen(const char *mode, const char *command, IV narg, - SV **args); + SV **args); static long find_pid(pTHX_ int pid); static void remove_dead_process(long child); static int terminate_process(DWORD pid, HANDLE process_handle, int sig); @@ -146,11 +146,11 @@ static char* wstr_to_str(const wchar_t* wstr); static long filetime_to_clock(PFILETIME ft); static BOOL filetime_from_time(PFILETIME ft, time_t t); static char* create_command_line(char *cname, STRLEN clen, - const char * const *args); + const char * const *args); static char* qualified_path(const char *cmd, bool other_exts); static void ansify_path(void); static LRESULT win32_process_message(HWND hwnd, UINT msg, - WPARAM wParam, LPARAM lParam); + WPARAM wParam, LPARAM lParam); #ifdef USE_ITHREADS static long find_pseudo_pid(pTHX_ int pid); @@ -221,7 +221,7 @@ my_invalid_parameter_handler(const wchar_t* expression, char* ansi_function; char* ansi_file; if (silent_invalid_parameter_handler) - return; + return; ansi_expression = wstr_to_str(expression); ansi_function = wstr_to_str(function); ansi_file = wstr_to_str(file); @@ -277,9 +277,9 @@ set_w32_module_name(void) /* normalize to forward slashes */ ptr = w32_module_name; while (*ptr) { - if (*ptr == '\\') - *ptr = '/'; - ++ptr; + if (*ptr == '\\') + *ptr = '/'; + ++ptr; } } @@ -296,18 +296,18 @@ get_regstr_from(HKEY handle, const char *valuename, SV **svp) retval = RegQueryValueEx(handle, valuename, 0, &type, NULL, &datalen); if (retval == ERROR_SUCCESS - && (type == REG_SZ || type == REG_EXPAND_SZ)) + && (type == REG_SZ || type == REG_EXPAND_SZ)) { - dTHX; - if (!*svp) - *svp = sv_2mortal(newSVpvs("")); - SvGROW(*svp, datalen); - retval = RegQueryValueEx(handle, valuename, 0, NULL, - (PBYTE)SvPVX(*svp), &datalen); - if (retval == ERROR_SUCCESS) { - str = SvPVX(*svp); - SvCUR_set(*svp,datalen-1); - } + dTHX; + if (!*svp) + *svp = sv_2mortal(newSVpvs("")); + SvGROW(*svp, datalen); + retval = RegQueryValueEx(handle, valuename, 0, NULL, + (PBYTE)SvPVX(*svp), &datalen); + if (retval == ERROR_SUCCESS) { + str = SvPVX(*svp); + SvCUR_set(*svp,datalen-1); + } } return str; } @@ -318,16 +318,16 @@ get_regstr(const char *valuename, SV **svp) { char *str; if (HKCU_Perl_hnd) { - str = get_regstr_from(HKCU_Perl_hnd, valuename, svp); - if (!str) - goto try_HKLM; + str = get_regstr_from(HKCU_Perl_hnd, valuename, svp); + if (!str) + goto try_HKLM; } else { - try_HKLM: - if (HKLM_Perl_hnd) - str = get_regstr_from(HKLM_Perl_hnd, valuename, svp); - else - str = NULL; + try_HKLM: + if (HKLM_Perl_hnd) + str = get_regstr_from(HKLM_Perl_hnd, valuename, svp); + else + str = NULL; } return str; } @@ -352,49 +352,49 @@ get_emd_part(SV **prev_pathp, STRLEN *const len, char *trailing_path, ...) baselen = strlen(base); if (!*w32_module_name) { - set_w32_module_name(); + set_w32_module_name(); } strcpy(mod_name, w32_module_name); ptr = strrchr(mod_name, '/'); while (ptr && strip) { /* look for directories to skip back */ - optr = ptr; - *ptr = '\0'; - ptr = strrchr(mod_name, '/'); - /* avoid stripping component if there is no slash, - * or it doesn't match ... */ - if (!ptr || stricmp(ptr+1, strip) != 0) { - /* ... but not if component matches m|5\.$patchlevel.*| */ - if (!ptr || !(*strip == '5' && *(ptr+1) == '5' - && strnEQ(strip, base, baselen) - && strnEQ(ptr+1, base, baselen))) - { - *optr = '/'; - ptr = optr; - } - } - strip = va_arg(ap, char *); + optr = ptr; + *ptr = '\0'; + ptr = strrchr(mod_name, '/'); + /* avoid stripping component if there is no slash, + * or it doesn't match ... */ + if (!ptr || stricmp(ptr+1, strip) != 0) { + /* ... but not if component matches m|5\.$patchlevel.*| */ + if (!ptr || !(*strip == '5' && *(ptr+1) == '5' + && strnEQ(strip, base, baselen) + && strnEQ(ptr+1, base, baselen))) + { + *optr = '/'; + ptr = optr; + } + } + strip = va_arg(ap, char *); } if (!ptr) { - ptr = mod_name; - *ptr++ = '.'; - *ptr = '/'; + ptr = mod_name; + *ptr++ = '.'; + *ptr = '/'; } va_end(ap); strcpy(++ptr, trailing_path); /* only add directory if it exists */ if (GetFileAttributes(mod_name) != (DWORD) -1) { - /* directory exists */ - dTHX; - if (!*prev_pathp) - *prev_pathp = sv_2mortal(newSVpvs("")); - else if (SvPVX(*prev_pathp)) - sv_catpvs(*prev_pathp, ";"); - sv_catpv(*prev_pathp, mod_name); - if(len) - *len = SvCUR(*prev_pathp); - return SvPVX(*prev_pathp); + /* directory exists */ + dTHX; + if (!*prev_pathp) + *prev_pathp = sv_2mortal(newSVpvs("")); + else if (SvPVX(*prev_pathp)) + sv_catpvs(*prev_pathp, ";"); + sv_catpv(*prev_pathp, mod_name); + if(len) + *len = SvCUR(*prev_pathp); + return SvPVX(*prev_pathp); } return NULL; @@ -411,7 +411,7 @@ win32_get_privlib(WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len) /* $stdlib = $HKCU{"lib-$]"} || $HKLM{"lib-$]"} || $HKCU{"lib"} || $HKLM{"lib"} || ""; */ sprintf(buffer, "%s-%s", stdlib, pl); if (!get_regstr(buffer, &sv)) - (void)get_regstr(stdlib, &sv); + (void)get_regstr(stdlib, &sv); #endif /* $stdlib .= ";$EMD/../../lib" */ @@ -420,7 +420,7 @@ win32_get_privlib(WIN32_NO_REGISTRY_M_(const char *pl) STRLEN *const len) static char * win32_get_xlib(const char *pl, WIN32_NO_REGISTRY_M_(const char *xlib) - const char *libname, STRLEN *const len) + const char *libname, STRLEN *const len) { #ifndef WIN32_NO_REGISTRY char regstr[40]; @@ -451,17 +451,17 @@ win32_get_xlib(const char *pl, WIN32_NO_REGISTRY_M_(const char *xlib) (void)get_emd_part(&sv2, NULL, pathstr, ARCHNAME, "bin", pl, NULL); if (!sv1 && !sv2) - return NULL; + return NULL; if (!sv1) { - sv1 = sv2; + sv1 = sv2; } else if (sv2) { dTHX; - sv_catpvs(sv1, ";"); - sv_catsv(sv1, sv2); + sv_catpvs(sv1, ";"); + sv_catsv(sv1, sv2); } if (len) - *len = SvCUR(sv1); + *len = SvCUR(sv1); return SvPVX(sv1); } @@ -493,31 +493,31 @@ has_shell_metachars(const char *ptr) * Shell variable interpolation (%VAR%) can also happen inside strings. */ while (*ptr) { - switch(*ptr) { - case '%': - return TRUE; - case '\'': - case '\"': - if (inquote) { - if (quote == *ptr) { - inquote = 0; - quote = '\0'; - } - } - else { - quote = *ptr; - inquote++; - } - break; - case '>': - case '<': - case '|': - if (!inquote) - return TRUE; - default: - break; - } - ++ptr; + switch(*ptr) { + case '%': + return TRUE; + case '\'': + case '\"': + if (inquote) { + if (quote == *ptr) { + inquote = 0; + quote = '\0'; + } + } + else { + quote = *ptr; + inquote++; + } + break; + case '>': + case '<': + case '|': + if (!inquote) + return TRUE; + default: + break; + } + ++ptr; } return FALSE; } @@ -552,7 +552,7 @@ win32_getpid(void) #ifdef USE_ITHREADS dTHX; if (w32_pseudo_id) - return -((int)w32_pseudo_id); + return -((int)w32_pseudo_id); #endif return _getpid(); } @@ -570,39 +570,39 @@ tokenize(const char *str, char **dest, char ***destv) char **retvstart = 0; int items = -1; if (str) { - int slen = strlen(str); - char *ret; - char **retv; - Newx(ret, slen+2, char); - Newx(retv, (slen+3)/2, char*); - - retstart = ret; - retvstart = retv; - *retv = ret; - items = 0; - while (*str) { - *ret = *str++; - if (*ret == '\\' && *str) - *ret = *str++; - else if (*ret == ' ') { - while (*str == ' ') - str++; - if (ret == retstart) - ret--; - else { - *ret = '\0'; - ++items; - if (*str) - *++retv = ret+1; - } - } - else if (!*str) - ++items; - ret++; - } - retvstart[items] = NULL; - *ret++ = '\0'; - *ret = '\0'; + int slen = strlen(str); + char *ret; + char **retv; + Newx(ret, slen+2, char); + Newx(retv, (slen+3)/2, char*); + + retstart = ret; + retvstart = retv; + *retv = ret; + items = 0; + while (*str) { + *ret = *str++; + if (*ret == '\\' && *str) + *ret = *str++; + else if (*ret == ' ') { + while (*str == ' ') + str++; + if (ret == retstart) + ret--; + else { + *ret = '\0'; + ++items; + if (*str) + *++retv = ret+1; + } + } + else if (!*str) + ++items; + ret++; + } + retvstart[items] = NULL; + *ret++ = '\0'; + *ret = '\0'; } *dest = retstart; *destv = retvstart; @@ -614,18 +614,18 @@ get_shell(void) { dTHX; if (!w32_perlshell_tokens) { - /* we don't use COMSPEC here for two reasons: - * 1. the same reason perl on UNIX doesn't use SHELL--rampant and - * uncontrolled unportability of the ensuing scripts. - * 2. PERL5SHELL could be set to a shell that may not be fit for - * interactive use (which is what most programs look in COMSPEC - * for). - */ - const char* defaultshell = "cmd.exe /x/d/c"; - const char *usershell = PerlEnv_getenv("PERL5SHELL"); - w32_perlshell_items = tokenize(usershell ? usershell : defaultshell, - &w32_perlshell_tokens, - &w32_perlshell_vec); + /* we don't use COMSPEC here for two reasons: + * 1. the same reason perl on UNIX doesn't use SHELL--rampant and + * uncontrolled unportability of the ensuing scripts. + * 2. PERL5SHELL could be set to a shell that may not be fit for + * interactive use (which is what most programs look in COMSPEC + * for). + */ + const char* defaultshell = "cmd.exe /x/d/c"; + const char *usershell = PerlEnv_getenv("PERL5SHELL"); + w32_perlshell_items = tokenize(usershell ? usershell : defaultshell, + &w32_perlshell_tokens, + &w32_perlshell_vec); } } @@ -642,54 +642,54 @@ Perl_do_aspawn(pTHX_ SV *really, SV **mark, SV **sp) PERL_ARGS_ASSERT_DO_ASPAWN; if (sp <= mark) - return -1; + return -1; get_shell(); Newx(argv, (sp - mark) + w32_perlshell_items + 2, char*); if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { - ++mark; - flag = SvIVx(*mark); + ++mark; + flag = SvIVx(*mark); } while (++mark <= sp) { - if (*mark && (str = SvPV_nolen(*mark))) - argv[index++] = str; - else - argv[index++] = ""; + if (*mark && (str = SvPV_nolen(*mark))) + argv[index++] = str; + else + argv[index++] = ""; } argv[index++] = 0; status = win32_spawnvp(flag, - (const char*)(really ? SvPV_nolen(really) : argv[0]), - (const char* const*)argv); + (const char*)(really ? SvPV_nolen(really) : argv[0]), + (const char* const*)argv); if (status < 0 && (eno = errno, (eno == ENOEXEC || eno == ENOENT))) { - /* possible shell-builtin, invoke with shell */ - int sh_items; - sh_items = w32_perlshell_items; - while (--index >= 0) - argv[index+sh_items] = argv[index]; - while (--sh_items >= 0) - argv[sh_items] = w32_perlshell_vec[sh_items]; + /* possible shell-builtin, invoke with shell */ + int sh_items; + sh_items = w32_perlshell_items; + while (--index >= 0) + argv[index+sh_items] = argv[index]; + while (--sh_items >= 0) + argv[sh_items] = w32_perlshell_vec[sh_items]; - status = win32_spawnvp(flag, - (const char*)(really ? SvPV_nolen(really) : argv[0]), - (const char* const*)argv); + status = win32_spawnvp(flag, + (const char*)(really ? SvPV_nolen(really) : argv[0]), + (const char* const*)argv); } if (flag == P_NOWAIT) { - PL_statusvalue = -1; /* >16bits hint for pp_system() */ + PL_statusvalue = -1; /* >16bits hint for pp_system() */ } else { - if (status < 0) { - if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno)); - status = 255 * 256; - } - else - status *= 256; - PL_statusvalue = status; + if (status < 0) { + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn \"%s\": %s", argv[0], strerror(errno)); + status = 255 * 256; + } + else + status *= 256; + PL_statusvalue = status; } Safefree(argv); return (status); @@ -701,20 +701,20 @@ find_next_space(const char *s) { bool in_quotes = FALSE; while (*s) { - /* ignore doubled backslashes, or backslash+quote */ - if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) { - s += 2; - } - /* keep track of when we're within quotes */ - else if (*s == '"') { - s++; - in_quotes = !in_quotes; - } - /* break it up only at spaces that aren't in quotes */ - else if (!in_quotes && isSPACE(*s)) - return (char*)s; - else - s++; + /* ignore doubled backslashes, or backslash+quote */ + if (*s == '\\' && (s[1] == '\\' || s[1] == '"')) { + s += 2; + } + /* keep track of when we're within quotes */ + else if (*s == '"') { + s++; + in_quotes = !in_quotes; + } + /* break it up only at spaces that aren't in quotes */ + else if (!in_quotes && isSPACE(*s)) + return (char*)s; + else + s++; } return (char*)s; } @@ -737,79 +737,79 @@ do_spawn2_handles(pTHX_ const char *cmd, int exectype, const int *handles) /* Save an extra exec if possible. See if there are shell * metacharacters in it */ if (!has_shell_metachars(cmd)) { - Newx(argv, strlen(cmd) / 2 + 2, char*); - Newx(cmd2, strlen(cmd) + 1, char); - strcpy(cmd2, cmd); - a = argv; - for (s = cmd2; *s;) { - while (*s && isSPACE(*s)) - s++; - if (*s) - *(a++) = s; - s = find_next_space(s); - if (*s) - *s++ = '\0'; - } - *a = NULL; - if (argv[0]) { - switch (exectype) { - case EXECF_SPAWN: - status = win32_spawnvp(P_WAIT, argv[0], - (const char* const*)argv); - break; - case EXECF_SPAWN_NOWAIT: - status = do_spawnvp_handles(P_NOWAIT, argv[0], - (const char* const*)argv, handles); - break; - case EXECF_EXEC: - status = win32_execvp(argv[0], (const char* const*)argv); - break; - } - if (status != -1 || errno == 0) - needToTry = FALSE; - } - Safefree(argv); - Safefree(cmd2); + Newx(argv, strlen(cmd) / 2 + 2, char*); + Newx(cmd2, strlen(cmd) + 1, char); + strcpy(cmd2, cmd); + a = argv; + for (s = cmd2; *s;) { + while (*s && isSPACE(*s)) + s++; + if (*s) + *(a++) = s; + s = find_next_space(s); + if (*s) + *s++ = '\0'; + } + *a = NULL; + if (argv[0]) { + switch (exectype) { + case EXECF_SPAWN: + status = win32_spawnvp(P_WAIT, argv[0], + (const char* const*)argv); + break; + case EXECF_SPAWN_NOWAIT: + status = do_spawnvp_handles(P_NOWAIT, argv[0], + (const char* const*)argv, handles); + break; + case EXECF_EXEC: + status = win32_execvp(argv[0], (const char* const*)argv); + break; + } + if (status != -1 || errno == 0) + needToTry = FALSE; + } + Safefree(argv); + Safefree(cmd2); } if (needToTry) { - char **argv; - int i = -1; - get_shell(); - Newx(argv, w32_perlshell_items + 2, char*); - while (++i < w32_perlshell_items) - argv[i] = w32_perlshell_vec[i]; - argv[i++] = (char *)cmd; - argv[i] = NULL; - switch (exectype) { - case EXECF_SPAWN: - status = win32_spawnvp(P_WAIT, argv[0], - (const char* const*)argv); - break; - case EXECF_SPAWN_NOWAIT: - status = do_spawnvp_handles(P_NOWAIT, argv[0], - (const char* const*)argv, handles); - break; - case EXECF_EXEC: - status = win32_execvp(argv[0], (const char* const*)argv); - break; - } - cmd = argv[0]; - Safefree(argv); + char **argv; + int i = -1; + get_shell(); + Newx(argv, w32_perlshell_items + 2, char*); + while (++i < w32_perlshell_items) + argv[i] = w32_perlshell_vec[i]; + argv[i++] = (char *)cmd; + argv[i] = NULL; + switch (exectype) { + case EXECF_SPAWN: + status = win32_spawnvp(P_WAIT, argv[0], + (const char* const*)argv); + break; + case EXECF_SPAWN_NOWAIT: + status = do_spawnvp_handles(P_NOWAIT, argv[0], + (const char* const*)argv, handles); + break; + case EXECF_EXEC: + status = win32_execvp(argv[0], (const char* const*)argv); + break; + } + cmd = argv[0]; + Safefree(argv); } if (exectype == EXECF_SPAWN_NOWAIT) { - PL_statusvalue = -1; /* >16bits hint for pp_system() */ + PL_statusvalue = -1; /* >16bits hint for pp_system() */ } else { - if (status < 0) { - if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s", - (exectype == EXECF_EXEC ? "exec" : "spawn"), - cmd, strerror(errno)); - status = 255 * 256; - } - else - status *= 256; - PL_statusvalue = status; + if (status < 0) { + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't %s \"%s\": %s", + (exectype == EXECF_EXEC ? "exec" : "spawn"), + cmd, strerror(errno)); + status = 255 * 256; + } + else + status *= 256; + PL_statusvalue = status; } return (status); } @@ -858,12 +858,12 @@ win32_opendir(const char *filename) len = strlen(filename); if (len == 0) { - errno = ENOENT; - return NULL; + errno = ENOENT; + return NULL; } if (len > MAX_PATH) { - errno = ENAMETOOLONG; - return NULL; + errno = ENAMETOOLONG; + return NULL; } /* Get us a DIR structure */ @@ -874,11 +874,11 @@ win32_opendir(const char *filename) /* bare drive name means look in cwd for drive */ if (len == 2 && isALPHA(scanname[0]) && scanname[1] == ':') { - scanname[len++] = '.'; - scanname[len++] = '/'; + scanname[len++] = '.'; + scanname[len++] = '/'; } else if (scanname[len-1] != '/' && scanname[len-1] != '\\') { - scanname[len++] = '/'; + scanname[len++] = '/'; } scanname[len++] = '*'; scanname[len] = '\0'; @@ -889,24 +889,24 @@ win32_opendir(const char *filename) dirp->handle = FindFirstFileW(PerlDir_mapW(wscanname), &wFindData); if (dirp->handle == INVALID_HANDLE_VALUE) { - DWORD err = GetLastError(); - /* FindFirstFile() fails on empty drives! */ - switch (err) { - case ERROR_FILE_NOT_FOUND: - return dirp; - case ERROR_NO_MORE_FILES: - case ERROR_PATH_NOT_FOUND: - errno = ENOENT; - break; - case ERROR_NOT_ENOUGH_MEMORY: - errno = ENOMEM; - break; - default: - errno = EINVAL; - break; - } - Safefree(dirp); - return NULL; + DWORD err = GetLastError(); + /* FindFirstFile() fails on empty drives! */ + switch (err) { + case ERROR_FILE_NOT_FOUND: + return dirp; + case ERROR_NO_MORE_FILES: + case ERROR_PATH_NOT_FOUND: + errno = ENOENT; + break; + case ERROR_NOT_ENOUGH_MEMORY: + errno = ENOMEM; + break; + default: + errno = EINVAL; + break; + } + Safefree(dirp); + return NULL; } use_default = FALSE; @@ -924,9 +924,9 @@ win32_opendir(const char *filename) */ idx = strlen(buffer)+1; if (idx < 256) - dirp->size = 256; + dirp->size = 256; else - dirp->size = idx; + dirp->size = idx; Newx(dirp->start, dirp->size, char); strcpy(dirp->start, buffer); dirp->nfiles++; @@ -945,30 +945,30 @@ win32_readdir(DIR *dirp) long len; if (dirp->curr) { - /* first set up the structure to return */ - len = strlen(dirp->curr); - strcpy(dirp->dirstr.d_name, dirp->curr); - dirp->dirstr.d_namlen = len; + /* first set up the structure to return */ + len = strlen(dirp->curr); + strcpy(dirp->dirstr.d_name, dirp->curr); + dirp->dirstr.d_namlen = len; - /* Fake an inode */ - dirp->dirstr.d_ino = dirp->curr - dirp->start; + /* Fake an inode */ + dirp->dirstr.d_ino = dirp->curr - dirp->start; - /* Now set up for the next call to readdir */ - dirp->curr += len + 1; - if (dirp->curr >= dirp->end) { - BOOL res; - char buffer[MAX_PATH*2]; + /* Now set up for the next call to readdir */ + dirp->curr += len + 1; + if (dirp->curr >= dirp->end) { + BOOL res; + char buffer[MAX_PATH*2]; if (dirp->handle == INVALID_HANDLE_VALUE) { res = 0; } - /* finding the next file that matches the wildcard - * (which should be all of them in this directory!). - */ - else { + /* finding the next file that matches the wildcard + * (which should be all of them in this directory!). + */ + else { WIN32_FIND_DATAW wFindData; - res = FindNextFileW(dirp->handle, &wFindData); - if (res) { + res = FindNextFileW(dirp->handle, &wFindData); + if (res) { BOOL use_default = FALSE; WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wFindData.cFileName, -1, @@ -980,33 +980,33 @@ win32_readdir(DIR *dirp) } } } - if (res) { - long endpos = dirp->end - dirp->start; - long newsize = endpos + strlen(buffer) + 1; - /* bump the string table size by enough for the - * new name and its null terminator */ - while (newsize > dirp->size) { - long curpos = dirp->curr - dirp->start; - Renew(dirp->start, dirp->size * 2, char); - dirp->size *= 2; - dirp->curr = dirp->start + curpos; - } - strcpy(dirp->start + endpos, buffer); - dirp->end = dirp->start + newsize; - dirp->nfiles++; - } - else { - dirp->curr = NULL; + if (res) { + long endpos = dirp->end - dirp->start; + long newsize = endpos + strlen(buffer) + 1; + /* bump the string table size by enough for the + * new name and its null terminator */ + while (newsize > dirp->size) { + long curpos = dirp->curr - dirp->start; + Renew(dirp->start, dirp->size * 2, char); + dirp->size *= 2; + dirp->curr = dirp->start + curpos; + } + strcpy(dirp->start + endpos, buffer); + dirp->end = dirp->start + newsize; + dirp->nfiles++; + } + else { + dirp->curr = NULL; if (dirp->handle != INVALID_HANDLE_VALUE) { FindClose(dirp->handle); dirp->handle = INVALID_HANDLE_VALUE; } } - } - return &(dirp->dirstr); + } + return &(dirp->dirstr); } else - return NULL; + return NULL; } /* Telldir returns the current string pointer position */ @@ -1038,7 +1038,7 @@ DllExport int win32_closedir(DIR *dirp) { if (dirp->handle != INVALID_HANDLE_VALUE) - FindClose(dirp->handle); + FindClose(dirp->handle); Safefree(dirp->start); Safefree(dirp); return 1; @@ -1145,7 +1145,7 @@ getlogin(void) char *buf = w32_getlogin_buffer; DWORD size = sizeof(w32_getlogin_buffer); if (GetUserName(buf,&size)) - return buf; + return buf; return (char*)NULL; } @@ -1169,16 +1169,16 @@ int mkstemp(const char *path) retry: if (i++ > 10) { /* give up */ - errno = ENOENT; - return -1; + errno = ENOENT; + return -1; } if (!GetTempFileNameA((LPCSTR)path, "plr", 1, buf)) { - errno = ENOENT; - return -1; + errno = ENOENT; + return -1; } fd = PerlLIO_open3(buf, O_CREAT|O_RDWR|O_EXCL, 0600); if (fd == -1) - goto retry; + goto retry; return fd; } #endif @@ -1188,8 +1188,8 @@ find_pid(pTHX_ int pid) { long child = w32_num_children; while (--child >= 0) { - if ((int)w32_child_pids[child] == pid) - return child; + if ((int)w32_child_pids[child] == pid) + return child; } return -1; } @@ -1198,13 +1198,13 @@ static void remove_dead_process(long child) { if (child >= 0) { - dTHX; - CloseHandle(w32_child_handles[child]); - Move(&w32_child_handles[child+1], &w32_child_handles[child], - (w32_num_children-child-1), HANDLE); - Move(&w32_child_pids[child+1], &w32_child_pids[child], - (w32_num_children-child-1), DWORD); - w32_num_children--; + dTHX; + CloseHandle(w32_child_handles[child]); + Move(&w32_child_handles[child+1], &w32_child_handles[child], + (w32_num_children-child-1), HANDLE); + Move(&w32_child_pids[child+1], &w32_child_pids[child], + (w32_num_children-child-1), DWORD); + w32_num_children--; } } @@ -1214,8 +1214,8 @@ find_pseudo_pid(pTHX_ int pid) { long child = w32_num_pseudo_children; while (--child >= 0) { - if ((int)w32_pseudo_child_pids[child] == pid) - return child; + if ((int)w32_pseudo_child_pids[child] == pid) + return child; } return -1; } @@ -1224,17 +1224,17 @@ static void remove_dead_pseudo_process(long child) { if (child >= 0) { - dTHX; - CloseHandle(w32_pseudo_child_handles[child]); - Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child], - (w32_num_pseudo_children-child-1), HANDLE); - Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child], - (w32_num_pseudo_children-child-1), DWORD); - Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child], - (w32_num_pseudo_children-child-1), HWND); - Move(&w32_pseudo_child_sigterm[child+1], &w32_pseudo_child_sigterm[child], - (w32_num_pseudo_children-child-1), char); - w32_num_pseudo_children--; + dTHX; + CloseHandle(w32_pseudo_child_handles[child]); + Move(&w32_pseudo_child_handles[child+1], &w32_pseudo_child_handles[child], + (w32_num_pseudo_children-child-1), HANDLE); + Move(&w32_pseudo_child_pids[child+1], &w32_pseudo_child_pids[child], + (w32_num_pseudo_children-child-1), DWORD); + Move(&w32_pseudo_child_message_hwnds[child+1], &w32_pseudo_child_message_hwnds[child], + (w32_num_pseudo_children-child-1), HWND); + Move(&w32_pseudo_child_sigterm[child+1], &w32_pseudo_child_sigterm[child], + (w32_num_pseudo_children-child-1), char); + w32_num_pseudo_children--; } } @@ -1373,14 +1373,14 @@ get_hwnd_delay(pTHX, long child, DWORD tries) if (hwnd != INVALID_HANDLE_VALUE) return hwnd; { - unsigned int count = 0; - /* No Sleep(1) if tries==0, just fail instead if we get this far. */ - while (count++ < tries) { - Sleep(1); - win32_async_check(aTHX); - hwnd = w32_pseudo_child_message_hwnds[child]; - if (hwnd != INVALID_HANDLE_VALUE) return hwnd; - } + unsigned int count = 0; + /* No Sleep(1) if tries==0, just fail instead if we get this far. */ + while (count++ < tries) { + Sleep(1); + win32_async_check(aTHX); + hwnd = w32_pseudo_child_message_hwnds[child]; + if (hwnd != INVALID_HANDLE_VALUE) return hwnd; + } } Perl_croak(aTHX_ "panic: child pseudo-process was never scheduled"); @@ -1394,64 +1394,64 @@ win32_kill(int pid, int sig) long child; #ifdef USE_ITHREADS if (pid < 0) { - /* it is a pseudo-forked child */ - child = find_pseudo_pid(aTHX_ -pid); - if (child >= 0) { - HANDLE hProcess = w32_pseudo_child_handles[child]; - switch (sig) { - case 0: - /* "Does process exist?" use of kill */ - return 0; - - case 9: { - /* kill -9 style un-graceful exit */ - /* Do a wait to make sure child starts and isn't in DLL - * Loader Lock */ - HWND hwnd = get_hwnd_delay(aTHX, child, 5); - if (TerminateThread(hProcess, sig)) { - /* Allow the scheduler to finish cleaning up the other - * thread. - * Otherwise, if we ExitProcess() before another context - * switch happens we will end up with a process exit - * code of "sig" instead of our own exit status. - * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976 - */ - Sleep(0); - remove_dead_pseudo_process(child); - return 0; - } - break; - } - - default: { - HWND hwnd = get_hwnd_delay(aTHX, child, 5); - /* We fake signals to pseudo-processes using Win32 - * message queue. */ - if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) || - PostThreadMessage(-pid, WM_USER_KILL, sig, 0)) - { - /* Don't wait for child process to terminate after we send a - * SIGTERM because the child may be blocked in a system call - * and never receive the signal. - */ - if (sig == SIGTERM) { - Sleep(0); - w32_pseudo_child_sigterm[child] = 1; - } - /* It might be us ... */ - PERL_ASYNC_CHECK(); - return 0; - } - break; - } - } /* switch */ - } + /* it is a pseudo-forked child */ + child = find_pseudo_pid(aTHX_ -pid); + if (child >= 0) { + HANDLE hProcess = w32_pseudo_child_handles[child]; + switch (sig) { + case 0: + /* "Does process exist?" use of kill */ + return 0; + + case 9: { + /* kill -9 style un-graceful exit */ + /* Do a wait to make sure child starts and isn't in DLL + * Loader Lock */ + HWND hwnd = get_hwnd_delay(aTHX, child, 5); + if (TerminateThread(hProcess, sig)) { + /* Allow the scheduler to finish cleaning up the other + * thread. + * Otherwise, if we ExitProcess() before another context + * switch happens we will end up with a process exit + * code of "sig" instead of our own exit status. + * https://rt.cpan.org/Ticket/Display.html?id=66016#txn-908976 + */ + Sleep(0); + remove_dead_pseudo_process(child); + return 0; + } + break; + } + + default: { + HWND hwnd = get_hwnd_delay(aTHX, child, 5); + /* We fake signals to pseudo-processes using Win32 + * message queue. */ + if ((hwnd != NULL && PostMessage(hwnd, WM_USER_KILL, sig, 0)) || + PostThreadMessage(-pid, WM_USER_KILL, sig, 0)) + { + /* Don't wait for child process to terminate after we send a + * SIGTERM because the child may be blocked in a system call + * and never receive the signal. + */ + if (sig == SIGTERM) { + Sleep(0); + w32_pseudo_child_sigterm[child] = 1; + } + /* It might be us ... */ + PERL_ASYNC_CHECK(); + return 0; + } + break; + } + } /* switch */ + } } else #endif { - child = find_pid(aTHX_ pid); - if (child >= 0) { + child = find_pid(aTHX_ pid); + if (child >= 0) { if (my_kill(pid, sig)) { DWORD exitcode = 0; if (GetExitCodeProcess(w32_child_handles[child], &exitcode) && @@ -1461,11 +1461,11 @@ win32_kill(int pid, int sig) } return 0; } - } - else { + } + else { if (my_kill(pid, sig)) return 0; - } + } } errno = EINVAL; return -1; @@ -1871,13 +1871,13 @@ win32_lstat(const char *path, Stat_t *sbuf) #define isSLASH(c) ((c) == '/' || (c) == '\\') #define SKIP_SLASHES(s) \ STMT_START { \ - while (*(s) && isSLASH(*(s))) \ - ++(s); \ + while (*(s) && isSLASH(*(s))) \ + ++(s); \ } STMT_END #define COPY_NONSLASHES(d,s) \ STMT_START { \ - while (*(s) && !isSLASH(*(s))) \ - *(d)++ = *(s)++; \ + while (*(s) && !isSLASH(*(s))) \ + *(d)++ = *(s)++; \ } STMT_END /* Find the longname of a given path. path is destructively modified. @@ -1892,78 +1892,78 @@ win32_longpath(char *path) char *start = path; char sep; if (!path) - return NULL; + return NULL; /* drive prefix */ if (isALPHA(path[0]) && path[1] == ':') { - start = path + 2; - *tmpstart++ = path[0]; - *tmpstart++ = ':'; + start = path + 2; + *tmpstart++ = path[0]; + *tmpstart++ = ':'; } /* UNC prefix */ else if (isSLASH(path[0]) && isSLASH(path[1])) { - start = path + 2; - *tmpstart++ = path[0]; - *tmpstart++ = path[1]; - SKIP_SLASHES(start); - COPY_NONSLASHES(tmpstart,start); /* copy machine name */ - if (*start) { - *tmpstart++ = *start++; - SKIP_SLASHES(start); - COPY_NONSLASHES(tmpstart,start); /* copy share name */ - } + start = path + 2; + *tmpstart++ = path[0]; + *tmpstart++ = path[1]; + SKIP_SLASHES(start); + COPY_NONSLASHES(tmpstart,start); /* copy machine name */ + if (*start) { + *tmpstart++ = *start++; + SKIP_SLASHES(start); + COPY_NONSLASHES(tmpstart,start); /* copy share name */ + } } *tmpstart = '\0'; while (*start) { - /* copy initial slash, if any */ - if (isSLASH(*start)) { - *tmpstart++ = *start++; - *tmpstart = '\0'; - SKIP_SLASHES(start); - } - - /* FindFirstFile() expands "." and "..", so we need to pass - * those through unmolested */ - if (*start == '.' - && (!start[1] || isSLASH(start[1]) - || (start[1] == '.' && (!start[2] || isSLASH(start[2]))))) - { - COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */ - *tmpstart = '\0'; - continue; - } - - /* if this is the end, bust outta here */ - if (!*start) - break; - - /* now we're at a non-slash; walk up to next slash */ - while (*start && !isSLASH(*start)) - ++start; - - /* stop and find full name of component */ - sep = *start; - *start = '\0'; - fhand = FindFirstFile(path,&fdata); - *start = sep; - if (fhand != INVALID_HANDLE_VALUE) { - STRLEN len = strlen(fdata.cFileName); - if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) { - strcpy(tmpstart, fdata.cFileName); - tmpstart += len; - FindClose(fhand); - } - else { - FindClose(fhand); - errno = ERANGE; - return NULL; - } - } - else { - /* failed a step, just return without side effects */ - errno = EINVAL; - return NULL; - } + /* copy initial slash, if any */ + if (isSLASH(*start)) { + *tmpstart++ = *start++; + *tmpstart = '\0'; + SKIP_SLASHES(start); + } + + /* FindFirstFile() expands "." and "..", so we need to pass + * those through unmolested */ + if (*start == '.' + && (!start[1] || isSLASH(start[1]) + || (start[1] == '.' && (!start[2] || isSLASH(start[2]))))) + { + COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */ + *tmpstart = '\0'; + continue; + } + + /* if this is the end, bust outta here */ + if (!*start) + break; + + /* now we're at a non-slash; walk up to next slash */ + while (*start && !isSLASH(*start)) + ++start; + + /* stop and find full name of component */ + sep = *start; + *start = '\0'; + fhand = FindFirstFile(path,&fdata); + *start = sep; + if (fhand != INVALID_HANDLE_VALUE) { + STRLEN len = strlen(fdata.cFileName); + if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) { + strcpy(tmpstart, fdata.cFileName); + tmpstart += len; + FindClose(fhand); + } + else { + FindClose(fhand); + errno = ERANGE; + return NULL; + } + } + else { + /* failed a step, just return without side effects */ + errno = EINVAL; + return NULL; + } } strcpy(path,tmpbuf); return path; @@ -1974,7 +1974,7 @@ out_of_memory(void) { if (PL_curinterp) - croak_no_mem(); + croak_no_mem(); exit(1); } @@ -2101,7 +2101,7 @@ win32_getenv(const char *name) needlen = GetEnvironmentVariableA(name,NULL,0); if (needlen != 0) { - curitem = sv_2mortal(newSVpvs("")); + curitem = sv_2mortal(newSVpvs("")); do { SvGROW(curitem, needlen+1); needlen = GetEnvironmentVariableA(name,SvPVX(curitem), @@ -2110,42 +2110,42 @@ win32_getenv(const char *name) SvCUR_set(curitem, needlen); } else { - last_err = GetLastError(); - if (last_err == ERROR_NOT_ENOUGH_MEMORY) { - /* It appears the variable is in the env, but the Win32 API - doesn't have a canned way of getting it. So we fall back to - grabbing the whole env and pulling this value out if possible */ - char *envv = GetEnvironmentStrings(); - char *cur = envv; - STRLEN len; - while (*cur) { - char *end = strchr(cur,'='); - if (end && end != cur) { - *end = '\0'; - if (strEQ(cur,name)) { - curitem = sv_2mortal(newSVpv(end+1,0)); - *end = '='; - break; - } - *end = '='; - cur = end + strlen(end+1)+2; - } - else if ((len = strlen(cur))) - cur += len+1; - } - FreeEnvironmentStrings(envv); - } + last_err = GetLastError(); + if (last_err == ERROR_NOT_ENOUGH_MEMORY) { + /* It appears the variable is in the env, but the Win32 API + doesn't have a canned way of getting it. So we fall back to + grabbing the whole env and pulling this value out if possible */ + char *envv = GetEnvironmentStrings(); + char *cur = envv; + STRLEN len; + while (*cur) { + char *end = strchr(cur,'='); + if (end && end != cur) { + *end = '\0'; + if (strEQ(cur,name)) { + curitem = sv_2mortal(newSVpv(end+1,0)); + *end = '='; + break; + } + *end = '='; + cur = end + strlen(end+1)+2; + } + else if ((len = strlen(cur))) + cur += len+1; + } + FreeEnvironmentStrings(envv); + } #ifndef WIN32_NO_REGISTRY - else { - /* last ditch: allow any environment variables that begin with 'PERL' - to be obtained from the registry, if found there */ - if (strBEGINs(name, "PERL")) - (void)get_regstr(name, &curitem); - } + else { + /* last ditch: allow any environment variables that begin with 'PERL' + to be obtained from the registry, if found there */ + if (strBEGINs(name, "PERL")) + (void)get_regstr(name, &curitem); + } #endif } if (curitem && SvCUR(curitem)) - return SvPVX(curitem); + return SvPVX(curitem); return NULL; } @@ -2206,16 +2206,16 @@ win32_times(struct tms *timebuf) clock_t process_time_so_far = clock(); if (GetProcessTimes(GetCurrentProcess(), &dummy, &dummy, &kernel,&user)) { - timebuf->tms_utime = filetime_to_clock(&user); - timebuf->tms_stime = filetime_to_clock(&kernel); - timebuf->tms_cutime = 0; - timebuf->tms_cstime = 0; + timebuf->tms_utime = filetime_to_clock(&user); + timebuf->tms_stime = filetime_to_clock(&kernel); + timebuf->tms_cutime = 0; + timebuf->tms_cstime = 0; } else { /* That failed - e.g. Win95 fallback to clock() */ - timebuf->tms_utime = process_time_so_far; - timebuf->tms_stime = 0; - timebuf->tms_cutime = 0; - timebuf->tms_cstime = 0; + timebuf->tms_utime = process_time_so_far; + timebuf->tms_stime = 0; + timebuf->tms_cutime = 0; + timebuf->tms_cstime = 0; } return process_time_so_far; } @@ -2308,7 +2308,7 @@ win32_utime(const char *filename, struct utimbuf *times) } if (filetime_from_time(&ftAccess, times->actime) && - filetime_from_time(&ftWrite, times->modtime)) { + filetime_from_time(&ftWrite, times->modtime)) { if (SetFileTime(handle, NULL, &ftAccess, &ftWrite)) { rc = 0; } @@ -2394,49 +2394,49 @@ win32_uname(struct utsname *name) /* nodename */ hep = win32_gethostbyname("localhost"); if (hep) { - STRLEN len = strlen(hep->h_name); - if (len <= nodemax) { - strcpy(name->nodename, hep->h_name); - } - else { - strncpy(name->nodename, hep->h_name, nodemax); - name->nodename[nodemax] = '\0'; - } + STRLEN len = strlen(hep->h_name); + if (len <= nodemax) { + strcpy(name->nodename, hep->h_name); + } + else { + strncpy(name->nodename, hep->h_name, nodemax); + name->nodename[nodemax] = '\0'; + } } else { - DWORD sz = nodemax; - if (!GetComputerName(name->nodename, &sz)) - *name->nodename = '\0'; + DWORD sz = nodemax; + if (!GetComputerName(name->nodename, &sz)) + *name->nodename = '\0'; } /* machine (architecture) */ { - SYSTEM_INFO info; - DWORD procarch; - char *arch; - GetSystemInfo(&info); + SYSTEM_INFO info; + DWORD procarch; + char *arch; + GetSystemInfo(&info); #if (defined(__MINGW32__) && !defined(_ANONYMOUS_UNION) && !defined(__MINGW_EXTENSION)) - procarch = info.u.s.wProcessorArchitecture; + procarch = info.u.s.wProcessorArchitecture; #else - procarch = info.wProcessorArchitecture; + procarch = info.wProcessorArchitecture; #endif - switch (procarch) { - case PROCESSOR_ARCHITECTURE_INTEL: - arch = "x86"; break; - case PROCESSOR_ARCHITECTURE_IA64: - arch = "ia64"; break; - case PROCESSOR_ARCHITECTURE_AMD64: - arch = "amd64"; break; - case PROCESSOR_ARCHITECTURE_UNKNOWN: - arch = "unknown"; break; - default: - sprintf(name->machine, "unknown(0x%x)", procarch); - arch = name->machine; - break; - } - if (name->machine != arch) - strcpy(name->machine, arch); + switch (procarch) { + case PROCESSOR_ARCHITECTURE_INTEL: + arch = "x86"; break; + case PROCESSOR_ARCHITECTURE_IA64: + arch = "ia64"; break; + case PROCESSOR_ARCHITECTURE_AMD64: + arch = "amd64"; break; + case PROCESSOR_ARCHITECTURE_UNKNOWN: + arch = "unknown"; break; + default: + sprintf(name->machine, "unknown(0x%x)", procarch); + arch = name->machine; + break; + } + if (name->machine != arch) + strcpy(name->machine, arch); } return 0; } @@ -2447,30 +2447,30 @@ int do_raise(pTHX_ int sig) { if (sig < SIG_SIZE) { - Sighandler_t handler = w32_sighandler[sig]; - if (handler == SIG_IGN) { - return 0; - } - else if (handler != SIG_DFL) { - (*handler)(sig); - return 0; - } - else { - /* Choose correct default behaviour */ - switch (sig) { + Sighandler_t handler = w32_sighandler[sig]; + if (handler == SIG_IGN) { + return 0; + } + else if (handler != SIG_DFL) { + (*handler)(sig); + return 0; + } + else { + /* Choose correct default behaviour */ + switch (sig) { #ifdef SIGCLD - case SIGCLD: + case SIGCLD: #endif #ifdef SIGCHLD - case SIGCHLD: + case SIGCHLD: #endif - case 0: - return 0; - case SIGTERM: - default: - break; - } - } + case 0: + return 0; + case SIGTERM: + default: + break; + } + } } /* Tell caller to exit thread/process as appropriate */ return 1; @@ -2545,9 +2545,9 @@ win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD result FT_t ticks = {0}; unsigned __int64 endtime = timeout; if (timeout != INFINITE) { - GetSystemTimeAsFileTime(&ticks.ft_val); - ticks.ft_i64 /= 10000; - endtime += ticks.ft_i64; + GetSystemTimeAsFileTime(&ticks.ft_val); + ticks.ft_i64 /= 10000; + endtime += ticks.ft_i64; } /* This was a race condition. Do not let a non INFINITE timeout to * MsgWaitForMultipleObjects roll under 0 creating a near @@ -2564,41 +2564,41 @@ win32_msgwait(pTHX_ DWORD count, LPHANDLE handles, DWORD timeout, LPDWORD result * causes msctf.dll to be loaded into Perl by kernel), see [perl #33096]. */ while (ticks.ft_i64 <= endtime) { - /* if timeout's type is lengthened, remember to split 64b timeout - * into multiple non-infinity runs of MWFMO */ - DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE, - (DWORD)(endtime - ticks.ft_i64), - QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE); - if (resultp) - *resultp = result; - if (result == WAIT_TIMEOUT) { - /* Ran out of time - explicit return of zero to avoid -ve if we - have scheduling issues + /* if timeout's type is lengthened, remember to split 64b timeout + * into multiple non-infinity runs of MWFMO */ + DWORD result = MsgWaitForMultipleObjects(count, handles, FALSE, + (DWORD)(endtime - ticks.ft_i64), + QS_POSTMESSAGE|QS_TIMER|QS_SENDMESSAGE); + if (resultp) + *resultp = result; + if (result == WAIT_TIMEOUT) { + /* Ran out of time - explicit return of zero to avoid -ve if we + have scheduling issues */ - return 0; - } - if (timeout != INFINITE) { - GetSystemTimeAsFileTime(&ticks.ft_val); - ticks.ft_i64 /= 10000; - } - if (result == WAIT_OBJECT_0 + count) { - /* Message has arrived - check it */ - (void)win32_async_check(aTHX); + return 0; + } + if (timeout != INFINITE) { + GetSystemTimeAsFileTime(&ticks.ft_val); + ticks.ft_i64 /= 10000; + } + if (result == WAIT_OBJECT_0 + count) { + /* Message has arrived - check it */ + (void)win32_async_check(aTHX); /* retry */ if (ticks.ft_i64 > endtime) endtime = ticks.ft_i64; continue; - } - else { - /* Not timeout or message - one of handles is ready */ - break; - } + } + else { + /* Not timeout or message - one of handles is ready */ + break; + } } /* If we are past the end say zero */ if (!ticks.ft_i64 || ticks.ft_i64 > endtime) - return 0; + return 0; /* compute time left to wait */ ticks.ft_i64 = endtime - ticks.ft_i64; /* if more ms than DWORD, then return max DWORD */ @@ -2616,52 +2616,52 @@ win32_internal_wait(pTHX_ int *status, DWORD timeout) #ifdef USE_ITHREADS if (w32_num_pseudo_children) { - win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles, - timeout, &waitcode); + win32_msgwait(aTHX_ w32_num_pseudo_children, w32_pseudo_child_handles, + timeout, &waitcode); /* Time out here if there are no other children to wait for. */ - if (waitcode == WAIT_TIMEOUT) { - if (!w32_num_children) { - return 0; - } - } - else if (waitcode != WAIT_FAILED) { - if (waitcode >= WAIT_ABANDONED_0 - && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children) - i = waitcode - WAIT_ABANDONED_0; - else - i = waitcode - WAIT_OBJECT_0; - if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) { - *status = (int)((exitcode & 0xff) << 8); - retval = (int)w32_pseudo_child_pids[i]; - remove_dead_pseudo_process(i); - return -retval; - } - } + if (waitcode == WAIT_TIMEOUT) { + if (!w32_num_children) { + return 0; + } + } + else if (waitcode != WAIT_FAILED) { + if (waitcode >= WAIT_ABANDONED_0 + && waitcode < WAIT_ABANDONED_0 + w32_num_pseudo_children) + i = waitcode - WAIT_ABANDONED_0; + else + i = waitcode - WAIT_OBJECT_0; + if (GetExitCodeThread(w32_pseudo_child_handles[i], &exitcode)) { + *status = (int)((exitcode & 0xff) << 8); + retval = (int)w32_pseudo_child_pids[i]; + remove_dead_pseudo_process(i); + return -retval; + } + } } #endif if (!w32_num_children) { - errno = ECHILD; - return -1; + errno = ECHILD; + return -1; } /* if a child exists, wait for it to die */ win32_msgwait(aTHX_ w32_num_children, w32_child_handles, timeout, &waitcode); if (waitcode == WAIT_TIMEOUT) { - return 0; + return 0; } if (waitcode != WAIT_FAILED) { - if (waitcode >= WAIT_ABANDONED_0 - && waitcode < WAIT_ABANDONED_0 + w32_num_children) - i = waitcode - WAIT_ABANDONED_0; - else - i = waitcode - WAIT_OBJECT_0; - if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) { - *status = (int)((exitcode & 0xff) << 8); - retval = (int)w32_child_pids[i]; - remove_dead_process(i); - return retval; - } + if (waitcode >= WAIT_ABANDONED_0 + && waitcode < WAIT_ABANDONED_0 + w32_num_children) + i = waitcode - WAIT_ABANDONED_0; + else + i = waitcode - WAIT_OBJECT_0; + if (GetExitCodeProcess(w32_child_handles[i], &exitcode) ) { + *status = (int)((exitcode & 0xff) << 8); + retval = (int)w32_child_pids[i]; + remove_dead_process(i); + return retval; + } } errno = GetLastError(); @@ -2676,71 +2676,71 @@ win32_waitpid(int pid, int *status, int flags) int retval = -1; long child; if (pid == -1) /* XXX threadid == 1 ? */ - return win32_internal_wait(aTHX_ status, timeout); + return win32_internal_wait(aTHX_ status, timeout); #ifdef USE_ITHREADS else if (pid < 0) { - child = find_pseudo_pid(aTHX_ -pid); - if (child >= 0) { - HANDLE hThread = w32_pseudo_child_handles[child]; - DWORD waitcode; - win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode); - if (waitcode == WAIT_TIMEOUT) { - return 0; - } - else if (waitcode == WAIT_OBJECT_0) { - if (GetExitCodeThread(hThread, &waitcode)) { - *status = (int)((waitcode & 0xff) << 8); - retval = (int)w32_pseudo_child_pids[child]; - remove_dead_pseudo_process(child); - return -retval; - } - } - else - errno = ECHILD; - } + child = find_pseudo_pid(aTHX_ -pid); + if (child >= 0) { + HANDLE hThread = w32_pseudo_child_handles[child]; + DWORD waitcode; + win32_msgwait(aTHX_ 1, &hThread, timeout, &waitcode); + if (waitcode == WAIT_TIMEOUT) { + return 0; + } + else if (waitcode == WAIT_OBJECT_0) { + if (GetExitCodeThread(hThread, &waitcode)) { + *status = (int)((waitcode & 0xff) << 8); + retval = (int)w32_pseudo_child_pids[child]; + remove_dead_pseudo_process(child); + return -retval; + } + } + else + errno = ECHILD; + } } #endif else { - HANDLE hProcess; - DWORD waitcode; - child = find_pid(aTHX_ pid); - if (child >= 0) { - hProcess = w32_child_handles[child]; - win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode); - if (waitcode == WAIT_TIMEOUT) { - return 0; - } - else if (waitcode == WAIT_OBJECT_0) { - if (GetExitCodeProcess(hProcess, &waitcode)) { - *status = (int)((waitcode & 0xff) << 8); - retval = (int)w32_child_pids[child]; - remove_dead_process(child); - return retval; - } - } - else - errno = ECHILD; - } - else { - hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid); - if (hProcess) { - win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode); - if (waitcode == WAIT_TIMEOUT) { + HANDLE hProcess; + DWORD waitcode; + child = find_pid(aTHX_ pid); + if (child >= 0) { + hProcess = w32_child_handles[child]; + win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode); + if (waitcode == WAIT_TIMEOUT) { + return 0; + } + else if (waitcode == WAIT_OBJECT_0) { + if (GetExitCodeProcess(hProcess, &waitcode)) { + *status = (int)((waitcode & 0xff) << 8); + retval = (int)w32_child_pids[child]; + remove_dead_process(child); + return retval; + } + } + else + errno = ECHILD; + } + else { + hProcess = OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid); + if (hProcess) { + win32_msgwait(aTHX_ 1, &hProcess, timeout, &waitcode); + if (waitcode == WAIT_TIMEOUT) { CloseHandle(hProcess); - return 0; - } - else if (waitcode == WAIT_OBJECT_0) { - if (GetExitCodeProcess(hProcess, &waitcode)) { - *status = (int)((waitcode & 0xff) << 8); - CloseHandle(hProcess); - return pid; - } - } - CloseHandle(hProcess); - } - else - errno = ECHILD; - } + return 0; + } + else if (waitcode == WAIT_OBJECT_0) { + if (GetExitCodeProcess(hProcess, &waitcode)) { + *status = (int)((waitcode & 0xff) << 8); + CloseHandle(hProcess); + return pid; + } + } + CloseHandle(hProcess); + } + else + errno = ECHILD; + } } return retval >= 0 ? pid : retval; } @@ -2758,8 +2758,8 @@ win32_sleep(unsigned int t) dTHX; /* Win32 times are in ms so *1000 in and /1000 out */ if (t > UINT_MAX / 1000) { - Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "sleep(%lu) too large", t); + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "sleep(%lu) too large", t); } return win32_msgwait(aTHX_ 0, NULL, t * 1000, NULL) / 1000; } @@ -2790,15 +2790,15 @@ win32_alarm(unsigned int sec) if (w32_message_hwnd == NULL) w32_timerid = SetTimer(NULL, w32_timerid, sec*1000, NULL); else { - w32_timerid = 1; + w32_timerid = 1; SetTimer(w32_message_hwnd, w32_timerid, sec*1000, NULL); } } else { - if (w32_timerid) { + if (w32_timerid) { KillTimer(w32_message_hwnd, w32_timerid); - w32_timerid = 0; - } + w32_timerid = 0; + } } return 0; } @@ -2831,29 +2831,29 @@ win32_flock(int fd, int oper) switch(oper) { case LOCK_SH: /* shared lock */ - if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o)) + if (LockFileEx(fh, 0, 0, LK_LEN, 0, &o)) i = 0; - break; + break; case LOCK_EX: /* exclusive lock */ - if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o)) + if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o)) i = 0; - break; + break; case LOCK_SH|LOCK_NB: /* non-blocking shared lock */ - if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o)) + if (LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o)) i = 0; - break; + break; case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */ - if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY, - 0, LK_LEN, 0, &o)) + if (LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY, + 0, LK_LEN, 0, &o)) i = 0; - break; + break; case LOCK_UN: /* unlock lock */ - if (UnlockFileEx(fh, 0, LK_LEN, 0, &o)) + if (UnlockFileEx(fh, 0, LK_LEN, 0, &o)) i = 0; - break; + break; default: /* unknown */ - errno = EINVAL; - return -1; + errno = EINVAL; + return -1; } if (i == -1) { if (GetLastError() == ERROR_LOCK_VIOLATION) @@ -2951,30 +2951,30 @@ win32_strerror(int e) if (e < 0 || e > sys_nerr) { dTHXa(NULL); - if (e < 0) - e = GetLastError(); + if (e < 0) + e = GetLastError(); #ifdef ERRNO_HAS_POSIX_SUPPLEMENT - /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno - * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but - * sys_nerr is still 43 and strerror() returns "Unknown error" for them. - * We must therefore still roll our own messages for these codes, and - * additionally map them to corresponding Windows (sockets) error codes - * first to avoid getting the wrong system message. - */ - else if (inRANGE(e, EADDRINUSE, EWOULDBLOCK)) { - e = convert_errno_to_wsa_error(e); - } + /* VC10+ and some MinGW/gcc-4.8+ define a "POSIX supplement" of errno + * values ranging from EADDRINUSE (100) to EWOULDBLOCK (140), but + * sys_nerr is still 43 and strerror() returns "Unknown error" for them. + * We must therefore still roll our own messages for these codes, and + * additionally map them to corresponding Windows (sockets) error codes + * first to avoid getting the wrong system message. + */ + else if (inRANGE(e, EADDRINUSE, EWOULDBLOCK)) { + e = convert_errno_to_wsa_error(e); + } #endif - aTHXa(PERL_GET_THX); - if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM + aTHXa(PERL_GET_THX); + if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |FORMAT_MESSAGE_IGNORE_INSERTS, NULL, e, 0, - w32_strerror_buffer, sizeof(w32_strerror_buffer), + w32_strerror_buffer, sizeof(w32_strerror_buffer), NULL) == 0) { - strcpy(w32_strerror_buffer, "Unknown Error"); + strcpy(w32_strerror_buffer, "Unknown Error"); } - return w32_strerror_buffer; + return w32_strerror_buffer; } #undef strerror return strerror(e); @@ -2987,29 +2987,29 @@ win32_str_os_error(void *sv, DWORD dwErr) DWORD dwLen; char *sMsg; dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER - |FORMAT_MESSAGE_IGNORE_INSERTS - |FORMAT_MESSAGE_FROM_SYSTEM, NULL, - dwErr, 0, (char *)&sMsg, 1, NULL); + |FORMAT_MESSAGE_IGNORE_INSERTS + |FORMAT_MESSAGE_FROM_SYSTEM, NULL, + dwErr, 0, (char *)&sMsg, 1, NULL); /* strip trailing whitespace and period */ if (0 < dwLen) { - do { - --dwLen; /* dwLen doesn't include trailing null */ - } while (0 < dwLen && isSPACE(sMsg[dwLen])); - if ('.' != sMsg[dwLen]) - dwLen++; - sMsg[dwLen] = '\0'; + do { + --dwLen; /* dwLen doesn't include trailing null */ + } while (0 < dwLen && isSPACE(sMsg[dwLen])); + if ('.' != sMsg[dwLen]) + dwLen++; + sMsg[dwLen] = '\0'; } if (0 == dwLen) { - sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/); - if (sMsg) - dwLen = sprintf(sMsg, - "Unknown error #0x%lX (lookup 0x%lX)", - dwErr, GetLastError()); + sMsg = (char*)LocalAlloc(0, 64/**sizeof(TCHAR)*/); + if (sMsg) + dwLen = sprintf(sMsg, + "Unknown error #0x%lX (lookup 0x%lX)", + dwErr, GetLastError()); } if (sMsg) { - dTHX; - sv_setpvn((SV*)sv, sMsg, dwLen); - LocalFree(sMsg); + dTHX; + sv_setpvn((SV*)sv, sMsg, dwLen); + LocalFree(sMsg); } } @@ -3064,16 +3064,16 @@ win32_fopen(const char *filename, const char *mode) FILE *f; if (!*filename) - return NULL; + return NULL; if (stricmp(filename, "/dev/null")==0) - filename = "NUL"; + filename = "NUL"; aTHXa(PERL_GET_THX); f = fopen(PerlDir_mapA(filename), mode); /* avoid buffering headaches for child processes */ if (f && *mode == 'a') - win32_fseek(f, 0, SEEK_END); + win32_fseek(f, 0, SEEK_END); return f; } @@ -3084,7 +3084,7 @@ win32_fdopen(int handle, const char *mode) f = fdopen(handle, (char *) mode); /* avoid buffering headaches for child processes */ if (f && *mode == 'a') - win32_fseek(f, 0, SEEK_END); + win32_fseek(f, 0, SEEK_END); return f; } @@ -3093,7 +3093,7 @@ win32_freopen(const char *path, const char *mode, FILE *stream) { dTHXa(NULL); if (stricmp(path, "/dev/null")==0) - path = "NUL"; + path = "NUL"; aTHXa(PERL_GET_THX); return freopen(PerlDir_mapA(path), mode, stream); @@ -3157,7 +3157,7 @@ win32_ftell(FILE *pf) { fpos_t pos; if (fgetpos(pf, &pos)) - return -1; + return -1; return (Off_t)pos; } @@ -3167,20 +3167,20 @@ win32_fseek(FILE *pf, Off_t offset,int origin) fpos_t pos; switch (origin) { case SEEK_CUR: - if (fgetpos(pf, &pos)) - return -1; - offset += pos; - break; + if (fgetpos(pf, &pos)) + return -1; + offset += pos; + break; case SEEK_END: - fseek(pf, 0, SEEK_END); - pos = _telli64(fileno(pf)); - offset += pos; - break; + fseek(pf, 0, SEEK_END); + pos = _telli64(fileno(pf)); + offset += pos; + break; case SEEK_SET: - break; + break; default: - errno = EINVAL; - return -1; + errno = EINVAL; + return -1; } return fsetpos(pf, &offset); } @@ -3219,25 +3219,25 @@ win32_tmpfd_mode(int mode) mode &= ~( O_ACCMODE | O_CREAT | O_EXCL ); mode |= O_RDWR; if (len && len < MAX_PATH) { - if (GetTempFileName(prefix, "plx", 0, filename)) { - HANDLE fh = CreateFile(filename, - DELETE | GENERIC_READ | GENERIC_WRITE, - 0, - NULL, - CREATE_ALWAYS, - FILE_ATTRIBUTE_NORMAL - | FILE_FLAG_DELETE_ON_CLOSE, - NULL); - if (fh != INVALID_HANDLE_VALUE) { - int fd = win32_open_osfhandle((intptr_t)fh, mode); - if (fd >= 0) { - PERL_DEB(dTHX;) - DEBUG_p(PerlIO_printf(Perl_debug_log, - "Created tmpfile=%s\n",filename)); - return fd; - } - } - } + if (GetTempFileName(prefix, "plx", 0, filename)) { + HANDLE fh = CreateFile(filename, + DELETE | GENERIC_READ | GENERIC_WRITE, + 0, + NULL, + CREATE_ALWAYS, + FILE_ATTRIBUTE_NORMAL + | FILE_FLAG_DELETE_ON_CLOSE, + NULL); + if (fh != INVALID_HANDLE_VALUE) { + int fd = win32_open_osfhandle((intptr_t)fh, mode); + if (fd >= 0) { + PERL_DEB(dTHX;) + DEBUG_p(PerlIO_printf(Perl_debug_log, + "Created tmpfile=%s\n",filename)); + return fd; + } + } + } } return -1; } @@ -3247,7 +3247,7 @@ win32_tmpfile(void) { int fd = win32_tmpfd(); if (fd >= 0) - return win32_fdopen(fd, "w+b"); + return win32_fdopen(fd, "w+b"); return NULL; } @@ -3297,13 +3297,13 @@ do_popen(const char *mode, const char *command, IV narg, SV **args) { stdfd = 0; /* stdin */ parent = 1; child = 0; - nhandle = STD_INPUT_HANDLE; + nhandle = STD_INPUT_HANDLE; } else if (strchr(mode,'r')) { stdfd = 1; /* stdout */ parent = 0; child = 1; - nhandle = STD_OUTPUT_HANDLE; + nhandle = STD_OUTPUT_HANDLE; } else return NULL; @@ -3336,44 +3336,44 @@ do_popen(const char *mode, const char *command, IV narg, SV **args) { /* CreateProcess() requires inheritable handles */ if (!SetHandleInformation((HANDLE)_get_osfhandle(p[child]), HANDLE_FLAG_INHERIT, - HANDLE_FLAG_INHERIT)) { + HANDLE_FLAG_INHERIT)) { goto cleanup; } /* start the child */ { - dTHX; - - if (command) { - if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1) - goto cleanup; - - } - else { - int i; - const char *exe_name; + dTHX; - Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *); - SAVEFREEPV(args_pvs); - for (i = 0; i < narg; ++i) - args_pvs[i] = SvPV_nolen(args[i]); - args_pvs[i] = NULL; - exe_name = qualified_path(args_pvs[0], TRUE); - if (!exe_name) - /* let CreateProcess() try to find it instead */ - exe_name = args_pvs[0]; + if (command) { + if ((childpid = do_spawn2_handles(aTHX_ command, EXECF_SPAWN_NOWAIT, handles)) == -1) + goto cleanup; - if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) { - goto cleanup; - } - } + } + else { + int i; + const char *exe_name; + + Newx(args_pvs, narg + 1 + w32_perlshell_items, const char *); + SAVEFREEPV(args_pvs); + for (i = 0; i < narg; ++i) + args_pvs[i] = SvPV_nolen(args[i]); + args_pvs[i] = NULL; + exe_name = qualified_path(args_pvs[0], TRUE); + if (!exe_name) + /* let CreateProcess() try to find it instead */ + exe_name = args_pvs[0]; + + if ((childpid = do_spawnvp_handles(P_NOWAIT, exe_name, args_pvs, handles)) == -1) { + goto cleanup; + } + } - win32_close(p[child]); + win32_close(p[child]); - sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid); + sv_setiv(*av_fetch(w32_fdpid, p[parent], TRUE), childpid); - /* set process id so that it can be returned by perl's open() */ - PL_forkprocess = childpid; + /* set process id so that it can be returned by perl's open() */ + PL_forkprocess = childpid; } /* we have an fd, return a file stream */ @@ -3420,12 +3420,12 @@ win32_pclose(PerlIO *pf) sv = *av_fetch(w32_fdpid, PerlIO_fileno(pf), TRUE); if (SvIOK(sv)) - childpid = SvIVX(sv); + childpid = SvIVX(sv); else - childpid = 0; + childpid = 0; if (!childpid) { - errno = EBADF; + errno = EBADF; return -1; } @@ -3453,10 +3453,10 @@ win32_link(const char *oldname, const char *newname) if (MultiByteToWideChar(CP_ACP, 0, oldname, -1, wOldName, MAX_PATH+1) && MultiByteToWideChar(CP_ACP, 0, newname, -1, wNewName, MAX_PATH+1) && - ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)), + ((aTHXa(PERL_GET_THX)), wcscpy(wOldName, PerlDir_mapW(wOldName)), CreateHardLinkW(PerlDir_mapW(wNewName), wOldName, NULL))) { - return 0; + return 0; } translate_to_errno(); return -1; @@ -3623,37 +3623,37 @@ win32_chsize(int fd, Off_t size) cur = win32_tell(fd); if (cur < 0) - return -1; + return -1; end = win32_lseek(fd, 0, SEEK_END); if (end < 0) - return -1; + return -1; extend = size - end; if (extend == 0) { - /* do nothing */ + /* do nothing */ } else if (extend > 0) { - /* must grow the file, padding with nulls */ - char b[4096]; - int oldmode = win32_setmode(fd, O_BINARY); - size_t count; - memset(b, '\0', sizeof(b)); - do { - count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend; - count = win32_write(fd, b, count); - if ((int)count < 0) { - retval = -1; - break; - } - } while ((extend -= count) > 0); - win32_setmode(fd, oldmode); + /* must grow the file, padding with nulls */ + char b[4096]; + int oldmode = win32_setmode(fd, O_BINARY); + size_t count; + memset(b, '\0', sizeof(b)); + do { + count = extend >= sizeof(b) ? sizeof(b) : (size_t)extend; + count = win32_write(fd, b, count); + if ((int)count < 0) { + retval = -1; + break; + } + } while ((extend -= count) > 0); + win32_setmode(fd, oldmode); } else { - /* shrink the file */ - win32_lseek(fd, size, SEEK_SET); - if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) { - errno = EACCES; - retval = -1; - } + /* shrink the file */ + win32_lseek(fd, size, SEEK_SET); + if (!SetEndOfFile((HANDLE)_get_osfhandle(fd))) { + errno = EACCES; + retval = -1; + } } win32_lseek(fd, cur, SEEK_SET); return retval; @@ -3683,7 +3683,7 @@ win32_open(const char *path, int flag, ...) va_end(ap); if (stricmp(path, "/dev/null")==0) - path = "NUL"; + path = "NUL"; aTHXa(PERL_GET_THX); return open(PerlDir_mapA(path), flag, pmode); @@ -3771,8 +3771,8 @@ DllExport int win32_chdir(const char *dir) { if (!dir || !*dir) { - errno = ENOENT; - return -1; + errno = ENOENT; + return -1; } return chdir(dir); } @@ -3807,7 +3807,7 @@ create_command_line(char *cname, STRLEN clen, const char * const *args) bool quote_next = FALSE; if (!cname) - cname = (char*)args[0]; + cname = (char*)args[0]; /* The NT cmd.exe shell has the following peculiarity that needs to be * worked around. It strips a leading and trailing dquote when any @@ -3825,44 +3825,44 @@ create_command_line(char *cname, STRLEN clen, const char * const *args) * always, making for the convolutions below :-( */ if (cname) { - if (!clen) - clen = strlen(cname); - - if (clen > 4 - && (stricmp(&cname[clen-4], ".bat") == 0 - || (stricmp(&cname[clen-4], ".cmd") == 0))) - { - bat_file = TRUE; + if (!clen) + clen = strlen(cname); + + if (clen > 4 + && (stricmp(&cname[clen-4], ".bat") == 0 + || (stricmp(&cname[clen-4], ".cmd") == 0))) + { + bat_file = TRUE; len += 3; - } - else { - char *exe = strrchr(cname, '/'); - char *exe2 = strrchr(cname, '\\'); - if (exe2 > exe) - exe = exe2; - if (exe) - ++exe; - else - exe = cname; - if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) { - cmd_shell = TRUE; - len += 3; - } - else if (stricmp(exe, "command.com") == 0 - || stricmp(exe, "command") == 0) - { - dumb_shell = TRUE; - } - } + } + else { + char *exe = strrchr(cname, '/'); + char *exe2 = strrchr(cname, '\\'); + if (exe2 > exe) + exe = exe2; + if (exe) + ++exe; + else + exe = cname; + if (stricmp(exe, "cmd.exe") == 0 || stricmp(exe, "cmd") == 0) { + cmd_shell = TRUE; + len += 3; + } + else if (stricmp(exe, "command.com") == 0 + || stricmp(exe, "command") == 0) + { + dumb_shell = TRUE; + } + } } DEBUG_p(PerlIO_printf(Perl_debug_log, "Args ")); for (index = 0; (arg = (char*)args[index]) != NULL; ++index) { - STRLEN curlen = strlen(arg); - if (!(arg[0] == '"' && arg[curlen-1] == '"')) - len += 2; /* assume quoting needed (worst case) */ - len += curlen + 1; - DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg)); + STRLEN curlen = strlen(arg); + if (!(arg[0] == '"' && arg[curlen-1] == '"')) + len += 2; /* assume quoting needed (worst case) */ + len += curlen + 1; + DEBUG_p(PerlIO_printf(Perl_debug_log, "[%s]",arg)); } DEBUG_p(PerlIO_printf(Perl_debug_log, "\n")); @@ -3871,76 +3871,76 @@ create_command_line(char *cname, STRLEN clen, const char * const *args) ptr = cmd; if (bat_file) { - *ptr++ = '"'; - extra_quotes = TRUE; + *ptr++ = '"'; + extra_quotes = TRUE; } for (index = 0; (arg = (char*)args[index]) != NULL; ++index) { - bool do_quote = 0; - STRLEN curlen = strlen(arg); - - /* we want to protect empty arguments and ones with spaces with - * dquotes, but only if they aren't already there */ - if (!dumb_shell) { - if (!curlen) { - do_quote = 1; - } - else if (quote_next) { - /* see if it really is multiple arguments pretending to - * be one and force a set of quotes around it */ - if (*find_next_space(arg)) - do_quote = 1; - } - else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) { - STRLEN i = 0; - while (i < curlen) { - if (isSPACE(arg[i])) { - do_quote = 1; - } - else if (arg[i] == '"') { - do_quote = 0; - break; - } - i++; - } - } - } - - if (do_quote) - *ptr++ = '"'; - - strcpy(ptr, arg); - ptr += curlen; - - if (do_quote) - *ptr++ = '"'; - - if (args[index+1]) - *ptr++ = ' '; - - if (!extra_quotes - && cmd_shell - && curlen >= 2 - && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */ - && stricmp(arg+curlen-2, "/c") == 0) - { - /* is there a next argument? */ - if (args[index+1]) { - /* are there two or more next arguments? */ - if (args[index+2]) { - *ptr++ = '"'; - extra_quotes = TRUE; - } - else { - /* single argument, force quoting if it has spaces */ - quote_next = TRUE; - } - } - } + bool do_quote = 0; + STRLEN curlen = strlen(arg); + + /* we want to protect empty arguments and ones with spaces with + * dquotes, but only if they aren't already there */ + if (!dumb_shell) { + if (!curlen) { + do_quote = 1; + } + else if (quote_next) { + /* see if it really is multiple arguments pretending to + * be one and force a set of quotes around it */ + if (*find_next_space(arg)) + do_quote = 1; + } + else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) { + STRLEN i = 0; + while (i < curlen) { + if (isSPACE(arg[i])) { + do_quote = 1; + } + else if (arg[i] == '"') { + do_quote = 0; + break; + } + i++; + } + } + } + + if (do_quote) + *ptr++ = '"'; + + strcpy(ptr, arg); + ptr += curlen; + + if (do_quote) + *ptr++ = '"'; + + if (args[index+1]) + *ptr++ = ' '; + + if (!extra_quotes + && cmd_shell + && curlen >= 2 + && *arg == '/' /* see if arg is "/c", "/x/c", "/x/d/c" etc. */ + && stricmp(arg+curlen-2, "/c") == 0) + { + /* is there a next argument? */ + if (args[index+1]) { + /* are there two or more next arguments? */ + if (args[index+2]) { + *ptr++ = '"'; + extra_quotes = TRUE; + } + else { + /* single argument, force quoting if it has spaces */ + quote_next = TRUE; + } + } + } } if (extra_quotes) - *ptr++ = '"'; + *ptr++ = '"'; *ptr = '\0'; @@ -3963,19 +3963,19 @@ qualified_path(const char *cmd, bool other_exts) int has_slash = 0; if (!cmd) - return NULL; + return NULL; fullcmd = (char*)cmd; while (*fullcmd) { - if (*fullcmd == '/' || *fullcmd == '\\') - has_slash++; - fullcmd++; - cmdlen++; + if (*fullcmd == '/' || *fullcmd == '\\') + has_slash++; + fullcmd++; + cmdlen++; } /* look in PATH */ { - dTHX; - pathstr = PerlEnv_getenv("PATH"); + dTHX; + pathstr = PerlEnv_getenv("PATH"); } /* worst case: PATH is a single directory; we need additional space * to append "/", ".exe" and trailing "\0" */ @@ -3983,65 +3983,65 @@ qualified_path(const char *cmd, bool other_exts) curfullcmd = fullcmd; while (1) { - DWORD res; - - /* start by appending the name to the current prefix */ - strcpy(curfullcmd, cmd); - curfullcmd += cmdlen; - - /* if it doesn't end with '.', or has no extension, try adding - * a trailing .exe first */ - if (cmd[cmdlen-1] != '.' - && (cmdlen < 4 || cmd[cmdlen-4] != '.')) - { - int i; - /* first extension is .exe */ - int ext_limit = other_exts ? C_ARRAY_LENGTH(exe_extensions) : 1; - for (i = 0; i < ext_limit; ++i) { - strcpy(curfullcmd, exe_extensions[i]); - res = GetFileAttributes(fullcmd); - if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY)) - return fullcmd; - } - - *curfullcmd = '\0'; - } - - /* that failed, try the bare name */ - res = GetFileAttributes(fullcmd); - if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY)) - return fullcmd; - - /* quit if no other path exists, or if cmd already has path */ - if (!pathstr || !*pathstr || has_slash) - break; - - /* skip leading semis */ - while (*pathstr == ';') - pathstr++; - - /* build a new prefix from scratch */ - curfullcmd = fullcmd; - while (*pathstr && *pathstr != ';') { - if (*pathstr == '"') { /* foo;"baz;etc";bar */ - pathstr++; /* skip initial '"' */ - while (*pathstr && *pathstr != '"') { + DWORD res; + + /* start by appending the name to the current prefix */ + strcpy(curfullcmd, cmd); + curfullcmd += cmdlen; + + /* if it doesn't end with '.', or has no extension, try adding + * a trailing .exe first */ + if (cmd[cmdlen-1] != '.' + && (cmdlen < 4 || cmd[cmdlen-4] != '.')) + { + int i; + /* first extension is .exe */ + int ext_limit = other_exts ? C_ARRAY_LENGTH(exe_extensions) : 1; + for (i = 0; i < ext_limit; ++i) { + strcpy(curfullcmd, exe_extensions[i]); + res = GetFileAttributes(fullcmd); + if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY)) + return fullcmd; + } + + *curfullcmd = '\0'; + } + + /* that failed, try the bare name */ + res = GetFileAttributes(fullcmd); + if (res != 0xFFFFFFFF && !(res & FILE_ATTRIBUTE_DIRECTORY)) + return fullcmd; + + /* quit if no other path exists, or if cmd already has path */ + if (!pathstr || !*pathstr || has_slash) + break; + + /* skip leading semis */ + while (*pathstr == ';') + pathstr++; + + /* build a new prefix from scratch */ + curfullcmd = fullcmd; + while (*pathstr && *pathstr != ';') { + if (*pathstr == '"') { /* foo;"baz;etc";bar */ + pathstr++; /* skip initial '"' */ + while (*pathstr && *pathstr != '"') { *curfullcmd++ = *pathstr++; - } - if (*pathstr) - pathstr++; /* skip trailing '"' */ - } - else { + } + if (*pathstr) + pathstr++; /* skip trailing '"' */ + } + else { *curfullcmd++ = *pathstr++; - } - } - if (*pathstr) - pathstr++; /* skip trailing semi */ - if (curfullcmd > fullcmd /* append a dir separator */ - && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\') - { - *curfullcmd++ = '\\'; - } + } + } + if (*pathstr) + pathstr++; /* skip trailing semi */ + if (curfullcmd > fullcmd /* append a dir separator */ + && curfullcmd[-1] != '/' && curfullcmd[-1] != '\\') + { + *curfullcmd++ = '\\'; + } } Safefree(fullcmd); @@ -4072,15 +4072,15 @@ win32_clearenv(void) char *cur = envv; STRLEN len; while (*cur) { - char *end = strchr(cur,'='); - if (end && end != cur) { - *end = '\0'; - SetEnvironmentVariable(cur, NULL); - *end = '='; - cur = end + strlen(end+1)+2; - } - else if ((len = strlen(cur))) - cur += len+1; + char *end = strchr(cur,'='); + if (end && end != cur) { + *end = '\0'; + SetEnvironmentVariable(cur, NULL); + *end = '='; + cur = end + strlen(end+1)+2; + } + else if ((len = strlen(cur))) + cur += len+1; } FreeEnvironmentStrings(envv); } @@ -4142,21 +4142,21 @@ do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv, STRLEN clen = 0; if (cname) { - clen = strlen(cname); - /* if command name contains dquotes, must remove them */ - if (strchr(cname, '"')) { - cmd = cname; - Newx(cname,clen+1,char); - clen = 0; - while (*cmd) { - if (*cmd != '"') { - cname[clen] = *cmd; - ++clen; - } - ++cmd; - } - cname[clen] = '\0'; - } + clen = strlen(cname); + /* if command name contains dquotes, must remove them */ + if (strchr(cname, '"')) { + cmd = cname; + Newx(cname,clen+1,char); + clen = 0; + while (*cmd) { + if (*cmd != '"') { + cname[clen] = *cmd; + ++clen; + } + ++cmd; + } + cname[clen] = '\0'; + } } cmd = create_command_line(cname, clen, argv); @@ -4167,23 +4167,23 @@ do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv, switch(mode) { case P_NOWAIT: /* asynch + remember result */ - if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) { - errno = EAGAIN; - ret = -1; - goto RETVAL; - } - /* Create a new process group so we can use GenerateConsoleCtrlEvent() - * in win32_kill() - */ + if (w32_num_children >= MAXIMUM_WAIT_OBJECTS) { + errno = EAGAIN; + ret = -1; + goto RETVAL; + } + /* Create a new process group so we can use GenerateConsoleCtrlEvent() + * in win32_kill() + */ create |= CREATE_NEW_PROCESS_GROUP; - /* FALL THROUGH */ + /* FALL THROUGH */ case P_WAIT: /* synchronous execution */ - break; + break; default: /* invalid mode */ - errno = EINVAL; - ret = -1; - goto RETVAL; + errno = EINVAL; + ret = -1; + goto RETVAL; } memset(&StartupInfo,0,sizeof(StartupInfo)); @@ -4204,15 +4204,15 @@ do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv, StartupInfo.hStdOutput = handles && handles[1] != -1 ? (HANDLE)_get_osfhandle(handles[1]) : tbl.childStdOut; StartupInfo.hStdError = handles && handles[2] != -1 ? - (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr; + (HANDLE)_get_osfhandle(handles[2]) : tbl.childStdErr; if (StartupInfo.hStdInput == INVALID_HANDLE_VALUE && - StartupInfo.hStdOutput == INVALID_HANDLE_VALUE && - StartupInfo.hStdError == INVALID_HANDLE_VALUE) + StartupInfo.hStdOutput == INVALID_HANDLE_VALUE && + StartupInfo.hStdError == INVALID_HANDLE_VALUE) { - create |= CREATE_NEW_CONSOLE; + create |= CREATE_NEW_CONSOLE; } else { - StartupInfo.dwFlags |= STARTF_USESTDHANDLES; + StartupInfo.dwFlags |= STARTF_USESTDHANDLES; } if (w32_use_showwindow) { StartupInfo.dwFlags |= STARTF_USESHOWWINDOW; @@ -4220,59 +4220,59 @@ do_spawnvp_handles(int mode, const char *cmdname, const char *const *argv, } DEBUG_p(PerlIO_printf(Perl_debug_log, "Spawning [%s] with [%s]\n", - cname,cmd)); + cname,cmd)); RETRY: if (!CreateProcess(cname, /* search PATH to find executable */ - cmd, /* executable, and its arguments */ - NULL, /* process attributes */ - NULL, /* thread attributes */ - TRUE, /* inherit handles */ - create, /* creation flags */ - (LPVOID)env, /* inherit environment */ - dir, /* inherit cwd */ - &StartupInfo, - &ProcessInformation)) + cmd, /* executable, and its arguments */ + NULL, /* process attributes */ + NULL, /* thread attributes */ + TRUE, /* inherit handles */ + create, /* creation flags */ + (LPVOID)env, /* inherit environment */ + dir, /* inherit cwd */ + &StartupInfo, + &ProcessInformation)) { - /* initial NULL argument to CreateProcess() does a PATH - * search, but it always first looks in the directory - * where the current process was started, which behavior - * is undesirable for backward compatibility. So we - * jump through our own hoops by picking out the path - * we really want it to use. */ - if (!fullcmd) { - fullcmd = qualified_path(cname, FALSE); - if (fullcmd) { - if (cname != cmdname) - Safefree(cname); - cname = fullcmd; - DEBUG_p(PerlIO_printf(Perl_debug_log, - "Retrying [%s] with same args\n", - cname)); - goto RETRY; - } - } - errno = ENOENT; - ret = -1; - goto RETVAL; + /* initial NULL argument to CreateProcess() does a PATH + * search, but it always first looks in the directory + * where the current process was started, which behavior + * is undesirable for backward compatibility. So we + * jump through our own hoops by picking out the path + * we really want it to use. */ + if (!fullcmd) { + fullcmd = qualified_path(cname, FALSE); + if (fullcmd) { + if (cname != cmdname) + Safefree(cname); + cname = fullcmd; + DEBUG_p(PerlIO_printf(Perl_debug_log, + "Retrying [%s] with same args\n", + cname)); + goto RETRY; + } + } + errno = ENOENT; + ret = -1; + goto RETVAL; } if (mode == P_NOWAIT) { - /* asynchronous spawn -- store handle, return PID */ - ret = (int)ProcessInformation.dwProcessId; + /* asynchronous spawn -- store handle, return PID */ + ret = (int)ProcessInformation.dwProcessId; - w32_child_handles[w32_num_children] = ProcessInformation.hProcess; - w32_child_pids[w32_num_children] = (DWORD)ret; - ++w32_num_children; + w32_child_handles[w32_num_children] = ProcessInformation.hProcess; + w32_child_pids[w32_num_children] = (DWORD)ret; + ++w32_num_children; } else { - DWORD status; - win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL); - /* FIXME: if msgwait returned due to message perhaps forward the - "signal" to the process + DWORD status; + win32_msgwait(aTHX_ 1, &ProcessInformation.hProcess, INFINITE, NULL); + /* FIXME: if msgwait returned due to message perhaps forward the + "signal" to the process */ - GetExitCodeProcess(ProcessInformation.hProcess, &status); - ret = (int)status; - CloseHandle(ProcessInformation.hProcess); + GetExitCodeProcess(ProcessInformation.hProcess, &status); + ret = (int)status; + CloseHandle(ProcessInformation.hProcess); } CloseHandle(ProcessInformation.hThread); @@ -4282,7 +4282,7 @@ RETVAL: PerlEnv_free_childdir(dir); Safefree(cmd); if (cname != cmdname) - Safefree(cname); + Safefree(cname); return ret; } @@ -4294,7 +4294,7 @@ win32_execv(const char *cmdname, const char *const *argv) /* if this is a pseudo-forked child, we just want to spawn * the new program, and return */ if (w32_pseudo_id) - return _spawnv(P_WAIT, cmdname, argv); + return _spawnv(P_WAIT, cmdname, argv); #endif return _execv(cmdname, argv); } @@ -4307,13 +4307,13 @@ win32_execvp(const char *cmdname, const char *const *argv) /* if this is a pseudo-forked child, we just want to spawn * the new program, and return */ if (w32_pseudo_id) { - int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv); - if (status != -1) { - my_exit(status); - return 0; - } - else - return status; + int status = win32_spawnvp(P_WAIT, cmdname, (const char *const *)argv); + if (status != -1) { + my_exit(status); + return 0; + } + else + return status; } #endif return _execvp(cmdname, argv); @@ -4536,17 +4536,17 @@ win32_fdupopen(FILE *pf) /* open the file in the same mode */ if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RD) { - mode[0] = 'r'; - mode[1] = 0; + mode[0] = 'r'; + mode[1] = 0; } else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_WR) { - mode[0] = 'a'; - mode[1] = 0; + mode[0] = 'a'; + mode[1] = 0; } else if (PERLIO_FILE_flag(pf) & PERLIO_FILE_flag_RW) { - mode[0] = 'r'; - mode[1] = '+'; - mode[2] = 0; + mode[0] = 'r'; + mode[1] = '+'; + mode[2] = 0; } /* it appears that the binmode is attached to the @@ -4557,7 +4557,7 @@ win32_fdupopen(FILE *pf) /* move the file pointer to the same position */ if (!fgetpos(pf, &pos)) { - fsetpos(pfdup, &pos); + fsetpos(pfdup, &pos); } return pfdup; } @@ -4573,17 +4573,17 @@ win32_dynaload(const char* filename) * so turn 'em back. */ first = strchr(filename, '/'); if (first) { - STRLEN len = strlen(filename); - if (len <= MAX_PATH) { - strcpy(buf, filename); - filename = &buf[first - filename]; - while (*filename) { - if (*filename == '/') - *(char*)filename = '\\'; - ++filename; - } - filename = buf; - } + STRLEN len = strlen(filename); + if (len <= MAX_PATH) { + strcpy(buf, filename); + filename = &buf[first - filename]; + while (*filename) { + if (*filename == '/') + *(char*)filename = '\\'; + ++filename; + } + filename = buf; + } } aTHXa(PERL_GET_THX); return LoadLibraryExA(PerlDir_mapA(filename), NULL, LOAD_WITH_ALTERED_SEARCH_PATH); @@ -4597,7 +4597,7 @@ XS(w32_SetChildShowWindow) unsigned short showwindow = w32_showwindow; if (items > 1) - croak_xs_usage(cv, "[showwindow]"); + croak_xs_usage(cv, "[showwindow]"); if (items == 0 || !SvOK(ST(0))) w32_use_showwindow = FALSE; @@ -4628,16 +4628,16 @@ XS(w32_GetCwd) * else return 'undef' */ if (ptr) { - SV *sv = sv_newmortal(); - sv_setpv(sv, ptr); - PerlEnv_free_childdir(ptr); + SV *sv = sv_newmortal(); + sv_setpv(sv, ptr); + PerlEnv_free_childdir(ptr); #ifndef INCOMPLETE_TAINTS - SvTAINTED_on(sv); + SvTAINTED_on(sv); #endif - ST(0) = sv; - XSRETURN(1); + ST(0) = sv; + XSRETURN(1); } XSRETURN_UNDEF; } @@ -4675,8 +4675,8 @@ win32_signal_context(void) dTHX; #ifdef MULTIPLICITY if (!my_perl) { - my_perl = PL_curinterp; - PERL_SET_THX(my_perl); + my_perl = PL_curinterp; + PERL_SET_THX(my_perl); } return my_perl; #else @@ -4692,7 +4692,7 @@ win32_ctrlhandler(DWORD dwCtrlType) dTHXa(PERL_GET_SIG_CONTEXT); if (!my_perl) - return FALSE; + return FALSE; #endif switch(dwCtrlType) { @@ -4702,37 +4702,37 @@ win32_ctrlhandler(DWORD dwCtrlType) console window's System menu, or by choosing the End Task command from the Task List */ - if (do_raise(aTHX_ 1)) /* SIGHUP */ - sig_terminate(aTHX_ 1); - return TRUE; + if (do_raise(aTHX_ 1)) /* SIGHUP */ + sig_terminate(aTHX_ 1); + return TRUE; case CTRL_C_EVENT: - /* A CTRL+c signal was received */ - if (do_raise(aTHX_ SIGINT)) - sig_terminate(aTHX_ SIGINT); - return TRUE; + /* A CTRL+c signal was received */ + if (do_raise(aTHX_ SIGINT)) + sig_terminate(aTHX_ SIGINT); + return TRUE; case CTRL_BREAK_EVENT: - /* A CTRL+BREAK signal was received */ - if (do_raise(aTHX_ SIGBREAK)) - sig_terminate(aTHX_ SIGBREAK); - return TRUE; + /* A CTRL+BREAK signal was received */ + if (do_raise(aTHX_ SIGBREAK)) + sig_terminate(aTHX_ SIGBREAK); + return TRUE; case CTRL_LOGOFF_EVENT: /* A signal that the system sends to all console processes when a user is logging off. This signal does not indicate which user is logging off, so no assumptions can be made. */ - break; + break; case CTRL_SHUTDOWN_EVENT: /* A signal that the system sends to all console processes when the system is shutting down. */ - if (do_raise(aTHX_ SIGTERM)) - sig_terminate(aTHX_ SIGTERM); - return TRUE; + if (do_raise(aTHX_ SIGTERM)) + sig_terminate(aTHX_ SIGTERM); + return TRUE; default: - break; + break; } return FALSE; } @@ -4869,13 +4869,13 @@ Perl_win32_init(int *argcp, char ***argvp) #ifdef WIN32_DYN_IOINFO_SIZE { - Size_t ioinfo_size = _msize((void*)__pioinfo[0]);; - if((SSize_t)ioinfo_size <= 0) { /* -1 is err */ - fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */ - exit(1); - } - ioinfo_size /= IOINFO_ARRAY_ELTS; - w32_ioinfo_size = ioinfo_size; + Size_t ioinfo_size = _msize((void*)__pioinfo[0]);; + if((SSize_t)ioinfo_size <= 0) { /* -1 is err */ + fprintf(stderr, "panic: invalid size for ioinfo\n"); /* no interp */ + exit(1); + } + ioinfo_size /= IOINFO_ARRAY_ELTS; + w32_ioinfo_size = ioinfo_size; } #endif @@ -4883,15 +4883,15 @@ Perl_win32_init(int *argcp, char ***argvp) #ifndef WIN32_NO_REGISTRY { - LONG retval; - retval = RegOpenKeyExW(HKEY_CURRENT_USER, L"SOFTWARE\\Perl", 0, KEY_READ, &HKCU_Perl_hnd); - if (retval != ERROR_SUCCESS) { - HKCU_Perl_hnd = NULL; - } - retval = RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SOFTWARE\\Perl", 0, KEY_READ, &HKLM_Perl_hnd); - if (retval != ERROR_SUCCESS) { - HKLM_Perl_hnd = NULL; - } + LONG retval; + retval = RegOpenKeyExW(HKEY_CURRENT_USER, L"SOFTWARE\\Perl", 0, KEY_READ, &HKCU_Perl_hnd); + if (retval != ERROR_SUCCESS) { + HKCU_Perl_hnd = NULL; + } + retval = RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SOFTWARE\\Perl", 0, KEY_READ, &HKLM_Perl_hnd); + if (retval != ERROR_SUCCESS) { + HKLM_Perl_hnd = NULL; + } } #endif @@ -4899,8 +4899,8 @@ Perl_win32_init(int *argcp, char ***argvp) FILETIME ft; if (!SystemTimeToFileTime(&time_t_epoch_base_systemtime, &ft)) { - fprintf(stderr, "panic: cannot convert base system time to filetime\n"); /* no interp */ - exit(1); + fprintf(stderr, "panic: cannot convert base system time to filetime\n"); /* no interp */ + exit(1); } time_t_epoch_base_filetime.LowPart = ft.dwLowDateTime; time_t_epoch_base_filetime.HighPart = ft.dwHighDateTime; @@ -4938,28 +4938,28 @@ win32_signal(int sig, Sighandler_t subcode) { dTHXa(NULL); if (sig < SIG_SIZE) { - int save_errno = errno; - Sighandler_t result; + int save_errno = errno; + Sighandler_t result; #ifdef SET_INVALID_PARAMETER_HANDLER - /* Silence our invalid parameter handler since we expect to make some - * calls with invalid signal numbers giving a SIG_ERR result. */ - BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE); + /* Silence our invalid parameter handler since we expect to make some + * calls with invalid signal numbers giving a SIG_ERR result. */ + BOOL oldvalue = set_silent_invalid_parameter_handler(TRUE); #endif - result = signal(sig, subcode); + result = signal(sig, subcode); #ifdef SET_INVALID_PARAMETER_HANDLER - set_silent_invalid_parameter_handler(oldvalue); + set_silent_invalid_parameter_handler(oldvalue); #endif - aTHXa(PERL_GET_THX); - if (result == SIG_ERR) { - result = w32_sighandler[sig]; - errno = save_errno; - } - w32_sighandler[sig] = subcode; - return result; + aTHXa(PERL_GET_THX); + if (result == SIG_ERR) { + result = w32_sighandler[sig]; + errno = save_errno; + } + w32_sighandler[sig] = subcode; + return result; } else { - errno = EINVAL; - return SIG_ERR; + errno = EINVAL; + return SIG_ERR; } } @@ -5105,16 +5105,16 @@ Perl_sys_intern_init(pTHX) w32_message_hwnd = CAST_HWND__(INVALID_HANDLE_VALUE); w32_poll_count = 0; for (i=0; i < SIG_SIZE; i++) { - w32_sighandler[i] = SIG_DFL; + w32_sighandler[i] = SIG_DFL; } # ifdef MULTIPLICITY if (my_perl == PL_curinterp) { # else { # endif - /* Force C runtime signal stuff to set its console handler */ - signal(SIGINT,win32_csighandler); - signal(SIGBREAK,win32_csighandler); + /* Force C runtime signal stuff to set its console handler */ + signal(SIGINT,win32_csighandler); + signal(SIGBREAK,win32_csighandler); /* We spawn asynchronous processes with the CREATE_NEW_PROCESS_GROUP * flag. This has the side-effect of disabling Ctrl-C events in all @@ -5124,8 +5124,8 @@ Perl_sys_intern_init(pTHX) */ SetConsoleCtrlHandler(NULL,FALSE); - /* Push our handler on top */ - SetConsoleCtrlHandler(win32_ctrlhandler,TRUE); + /* Push our handler on top */ + SetConsoleCtrlHandler(win32_ctrlhandler,TRUE); } } @@ -5138,8 +5138,8 @@ Perl_sys_intern_clear(pTHX) /* NOTE: w32_fdpid is freed by sv_clean_all() */ Safefree(w32_children); if (w32_timerid) { - KillTimer(w32_message_hwnd, w32_timerid); - w32_timerid = 0; + KillTimer(w32_message_hwnd, w32_timerid); + w32_timerid = 0; } if (w32_message_hwnd != NULL && w32_message_hwnd != INVALID_HANDLE_VALUE) DestroyWindow(w32_message_hwnd); @@ -5148,7 +5148,7 @@ Perl_sys_intern_clear(pTHX) # else { # endif - SetConsoleCtrlHandler(win32_ctrlhandler,FALSE); + SetConsoleCtrlHandler(win32_ctrlhandler,FALSE); } # ifdef USE_ITHREADS Safefree(w32_pseudo_children); diff --git a/win32/win32.h b/win32/win32.h index 40ab7e043a..2325d0edc9 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -111,7 +111,7 @@ #if (defined(__GNUC__) && defined(__MINGW32__) && \ !defined(__MINGW64_VERSION_MAJOR) && !defined(__clang__) && \ - ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ <= 5)))) + ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ <= 5)))) /* use default fallbacks from perl.h for this particular GCC */ #else # if !defined(PERLDLL) && !defined(PERL_EXT_RE_BUILD) @@ -181,10 +181,10 @@ WINBASEAPI LPCH WINAPI GetEnvironmentStringsA(VOID); #endif struct tms { - long tms_utime; - long tms_stime; - long tms_cutime; - long tms_cstime; + long tms_utime; + long tms_stime; + long tms_cutime; + long tms_cstime; }; #ifndef SYS_NMLN diff --git a/win32/win32io.c b/win32/win32io.c index 814fc8bf8f..2b4f27611d 100644 --- a/win32/win32io.c +++ b/win32/win32io.c @@ -63,8 +63,8 @@ PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab PerlIOBase(f)->flags |= PERLIO_F_OPEN; Perl_ck_warner_d(aTHX_ - packWARN(WARN_EXPERIMENTAL__WIN32_PERLIO), - "PerlIO layer ':win32' is experimental"); + packWARN(WARN_EXPERIMENTAL__WIN32_PERLIO), + "PerlIO layer ':win32' is experimental"); return code; } diff --git a/win32/win32iop.h b/win32/win32iop.h index fd6b1c151b..9733d7b532 100644 --- a/win32/win32iop.h +++ b/win32/win32iop.h @@ -88,7 +88,7 @@ DllExport int win32_isatty(int fd); DllExport int win32_read(int fd, void *buf, unsigned int cnt); DllExport int win32_write(int fd, const void *buf, unsigned int cnt); DllExport int win32_spawnvp(int mode, const char *cmdname, - const char *const *argv); + const char *const *argv); DllExport int win32_mkdir(const char *dir, int mode); DllExport int win32_rmdir(const char *dir); DllExport int win32_chdir(const char *dir); diff --git a/win32/win32sck.c b/win32/win32sck.c index 2798ee507b..ef5c682101 100644 --- a/win32/win32sck.c +++ b/win32/win32sck.c @@ -35,19 +35,19 @@ #define StartSockets() \ STMT_START { \ - if (!wsock_started) \ - start_sockets(); \ + if (!wsock_started) \ + start_sockets(); \ } STMT_END #define SOCKET_TEST(x, y) \ STMT_START { \ - StartSockets(); \ - if((x) == (y)) \ - { \ - int wsaerr = WSAGetLastError(); \ - errno = convert_wsa_error_to_errno(wsaerr); \ - SetLastError(wsaerr); \ - } \ + StartSockets(); \ + if((x) == (y)) \ + { \ + int wsaerr = WSAGetLastError(); \ + errno = convert_wsa_error_to_errno(wsaerr); \ + SetLastError(wsaerr); \ + } \ } STMT_END #define SOCKET_TEST_ERROR(x) SOCKET_TEST(x, SOCKET_ERROR) @@ -66,7 +66,7 @@ EXTERN_C void EndSockets(void) { if (wsock_started) - WSACleanup(); + WSACleanup(); } /* Translate WSAExxx values to corresponding Exxx values where possible. Not all @@ -89,107 +89,107 @@ convert_wsa_error_to_errno(int wsaerr) { switch (wsaerr) { case WSAEINTR: - return EINTR; + return EINTR; case WSAEBADF: - return EBADF; + return EBADF; case WSAEACCES: - return EACCES; + return EACCES; case WSAEFAULT: - return EFAULT; + return EFAULT; case WSAEINVAL: - return EINVAL; + return EINVAL; case WSAEMFILE: - return EMFILE; + return EMFILE; case WSAEWOULDBLOCK: - return EWOULDBLOCK; + return EWOULDBLOCK; case WSAEINPROGRESS: - return EINPROGRESS; + return EINPROGRESS; case WSAEALREADY: - return EALREADY; + return EALREADY; case WSAENOTSOCK: - return ENOTSOCK; + return ENOTSOCK; case WSAEDESTADDRREQ: - return EDESTADDRREQ; + return EDESTADDRREQ; case WSAEMSGSIZE: - return EMSGSIZE; + return EMSGSIZE; case WSAEPROTOTYPE: - return EPROTOTYPE; + return EPROTOTYPE; case WSAENOPROTOOPT: - return ENOPROTOOPT; + return ENOPROTOOPT; case WSAEPROTONOSUPPORT: - return EPROTONOSUPPORT; + return EPROTONOSUPPORT; case WSAESOCKTNOSUPPORT: - return ESOCKTNOSUPPORT; + return ESOCKTNOSUPPORT; case WSAEOPNOTSUPP: - return EOPNOTSUPP; + return EOPNOTSUPP; case WSAEPFNOSUPPORT: - return EPFNOSUPPORT; + return EPFNOSUPPORT; case WSAEAFNOSUPPORT: - return EAFNOSUPPORT; + return EAFNOSUPPORT; case WSAEADDRINUSE: - return EADDRINUSE; + return EADDRINUSE; case WSAEADDRNOTAVAIL: - return EADDRNOTAVAIL; + return EADDRNOTAVAIL; case WSAENETDOWN: - return ENETDOWN; + return ENETDOWN; case WSAENETUNREACH: - return ENETUNREACH; + return ENETUNREACH; case WSAENETRESET: - return ENETRESET; + return ENETRESET; case WSAECONNABORTED: - return ECONNABORTED; + return ECONNABORTED; case WSAECONNRESET: - return ECONNRESET; + return ECONNRESET; case WSAENOBUFS: - return ENOBUFS; + return ENOBUFS; case WSAEISCONN: - return EISCONN; + return EISCONN; case WSAENOTCONN: - return ENOTCONN; + return ENOTCONN; case WSAESHUTDOWN: - return ESHUTDOWN; + return ESHUTDOWN; case WSAETOOMANYREFS: - return ETOOMANYREFS; + return ETOOMANYREFS; case WSAETIMEDOUT: - return ETIMEDOUT; + return ETIMEDOUT; case WSAECONNREFUSED: - return ECONNREFUSED; + return ECONNREFUSED; case WSAELOOP: - return ELOOP; + return ELOOP; case WSAENAMETOOLONG: - return ENAMETOOLONG; + return ENAMETOOLONG; case WSAEHOSTDOWN: - return WSAEHOSTDOWN; /* EHOSTDOWN is not defined */ + return WSAEHOSTDOWN; /* EHOSTDOWN is not defined */ case WSAEHOSTUNREACH: - return EHOSTUNREACH; + return EHOSTUNREACH; case WSAENOTEMPTY: - return ENOTEMPTY; + return ENOTEMPTY; case WSAEPROCLIM: - return EPROCLIM; + return EPROCLIM; case WSAEUSERS: - return EUSERS; + return EUSERS; case WSAEDQUOT: - return EDQUOT; + return EDQUOT; case WSAESTALE: - return ESTALE; + return ESTALE; case WSAEREMOTE: - return EREMOTE; + return EREMOTE; case WSAEDISCON: - return WSAEDISCON; /* EDISCON is not defined */ + return WSAEDISCON; /* EDISCON is not defined */ case WSAENOMORE: - return WSAENOMORE; /* ENOMORE is not defined */ + return WSAENOMORE; /* ENOMORE is not defined */ #ifdef WSAECANCELLED case WSAECANCELLED: /* New in WinSock2 */ - return ECANCELED; + return ECANCELED; #endif case WSAEINVALIDPROCTABLE: - return WSAEINVALIDPROCTABLE; /* EINVALIDPROCTABLE is not defined */ + return WSAEINVALIDPROCTABLE; /* EINVALIDPROCTABLE is not defined */ case WSAEINVALIDPROVIDER: - return WSAEINVALIDPROVIDER; /* EINVALIDPROVIDER is not defined */ + return WSAEINVALIDPROVIDER; /* EINVALIDPROVIDER is not defined */ case WSAEPROVIDERFAILEDINIT: - return WSAEPROVIDERFAILEDINIT; /* EPROVIDERFAILEDINIT is not defined */ + return WSAEPROVIDERFAILEDINIT; /* EPROVIDERFAILEDINIT is not defined */ case WSAEREFUSED: - return WSAEREFUSED; /* EREFUSED is not defined */ + return WSAEREFUSED; /* EREFUSED is not defined */ } return wsaerr; @@ -213,113 +213,113 @@ convert_errno_to_wsa_error(int err) { switch (err) { case EADDRINUSE: - return WSAEADDRINUSE; + return WSAEADDRINUSE; case EADDRNOTAVAIL: - return WSAEADDRNOTAVAIL; + return WSAEADDRNOTAVAIL; case EAFNOSUPPORT: - return WSAEAFNOSUPPORT; + return WSAEAFNOSUPPORT; case EALREADY: - return WSAEALREADY; + return WSAEALREADY; #ifdef EBADMSG case EBADMSG: /* Not defined in gcc-4.8.0 */ - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif case ECANCELED: #ifdef WSAECANCELLED - return WSAECANCELLED; /* New in WinSock2 */ + return WSAECANCELLED; /* New in WinSock2 */ #else - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif case ECONNABORTED: - return WSAECONNABORTED; + return WSAECONNABORTED; case ECONNREFUSED: - return WSAECONNREFUSED; + return WSAECONNREFUSED; case ECONNRESET: - return WSAECONNRESET; + return WSAECONNRESET; case EDESTADDRREQ: - return WSAEDESTADDRREQ; + return WSAEDESTADDRREQ; case EHOSTUNREACH: - return WSAEHOSTUNREACH; + return WSAEHOSTUNREACH; #ifdef EIDRM case EIDRM: /* Not defined in gcc-4.8.0 */ - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif case EINPROGRESS: - return WSAEINPROGRESS; + return WSAEINPROGRESS; case EISCONN: - return WSAEISCONN; + return WSAEISCONN; case ELOOP: - return WSAELOOP; + return WSAELOOP; case EMSGSIZE: - return WSAEMSGSIZE; + return WSAEMSGSIZE; case ENETDOWN: - return WSAENETDOWN; + return WSAENETDOWN; case ENETRESET: - return WSAENETRESET; + return WSAENETRESET; case ENETUNREACH: - return WSAENETUNREACH; + return WSAENETUNREACH; case ENOBUFS: - return WSAENOBUFS; + return WSAENOBUFS; #ifdef ENODATA case ENODATA: /* Not defined in gcc-4.8.0 */ - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif #ifdef ENOLINK case ENOLINK: /* Not defined in gcc-4.8.0 */ - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif #ifdef ENOMSG case ENOMSG: /* Not defined in gcc-4.8.0 */ - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif case ENOPROTOOPT: - return WSAENOPROTOOPT; + return WSAENOPROTOOPT; #ifdef ENOSR case ENOSR: /* Not defined in gcc-4.8.0 */ - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif #ifdef ENOSTR case ENOSTR: /* Not defined in gcc-4.8.0 */ - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif case ENOTCONN: - return WSAENOTCONN; + return WSAENOTCONN; #ifdef ENOTRECOVERABLE case ENOTRECOVERABLE: /* Not defined in gcc-4.8.0 */ - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif case ENOTSOCK: - return WSAENOTSOCK; + return WSAENOTSOCK; case ENOTSUP: - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; case EOPNOTSUPP: - return WSAEOPNOTSUPP; + return WSAEOPNOTSUPP; #ifdef EOTHER case EOTHER: /* Not defined in gcc-4.8.0 */ - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif case EOVERFLOW: - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; case EOWNERDEAD: - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; case EPROTO: - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; case EPROTONOSUPPORT: - return WSAEPROTONOSUPPORT; + return WSAEPROTONOSUPPORT; case EPROTOTYPE: - return WSAEPROTOTYPE; + return WSAEPROTOTYPE; #ifdef ETIME case ETIME: /* Not defined in gcc-4.8.0 */ - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif case ETIMEDOUT: - return WSAETIMEDOUT; + return WSAETIMEDOUT; #ifdef ETXTBSY case ETXTBSY: /* Not defined in gcc-4.8.0 */ - return ERROR_INVALID_FUNCTION; + return ERROR_INVALID_FUNCTION; #endif case EWOULDBLOCK: - return WSAEWOULDBLOCK; + return WSAEWOULDBLOCK; } return err; @@ -339,9 +339,9 @@ start_sockets(void) */ version = 0x2; if(ret = WSAStartup(version, &retdata)) - Perl_croak_nocontext("Unable to locate winsock library!\n"); + Perl_croak_nocontext("Unable to locate winsock library!\n"); if(retdata.wVersion != version) - Perl_croak_nocontext("Could not find version 2.0 of winsock dll\n"); + Perl_croak_nocontext("Could not find version 2.0 of winsock dll\n"); /* atexit((void (*)(void)) EndSockets); */ wsock_started = 1; @@ -482,7 +482,7 @@ win32_recvfrom(SOCKET s, char *buf, int len, int flags, struct sockaddr *from, i * of sockets, so go the extra mile. */ if (r != SOCKET_ERROR && frombufsize == *fromlen) - (void)win32_getpeername(s, from, fromlen); + (void)win32_getpeername(s, from, fromlen); return r; } @@ -501,33 +501,33 @@ win32_select(int nfds, Perl_fd_set* rd, Perl_fd_set* wr, Perl_fd_set* ex, const FD_ZERO(&nwr); FD_ZERO(&nex); for (i = 0; i < nfds; i++) { - if (rd && PERL_FD_ISSET(i,rd)) { - fd = TO_SOCKET(i); - FD_SET((unsigned)fd, &nrd); + if (rd && PERL_FD_ISSET(i,rd)) { + fd = TO_SOCKET(i); + FD_SET((unsigned)fd, &nrd); just_sleep = FALSE; - } - if (wr && PERL_FD_ISSET(i,wr)) { - fd = TO_SOCKET(i); - FD_SET((unsigned)fd, &nwr); + } + if (wr && PERL_FD_ISSET(i,wr)) { + fd = TO_SOCKET(i); + FD_SET((unsigned)fd, &nwr); just_sleep = FALSE; - } - if (ex && PERL_FD_ISSET(i,ex)) { - fd = TO_SOCKET(i); - FD_SET((unsigned)fd, &nex); + } + if (ex && PERL_FD_ISSET(i,ex)) { + fd = TO_SOCKET(i); + FD_SET((unsigned)fd, &nex); just_sleep = FALSE; - } + } } /* winsock seems incapable of dealing with all three fd_sets being empty, * so do the (millisecond) sleep as a special case */ if (just_sleep) { - if (timeout) - Sleep(timeout->tv_sec * 1000 + - timeout->tv_usec / 1000); /* do the best we can */ - else - Sleep(UINT_MAX); - return 0; + if (timeout) + Sleep(timeout->tv_sec * 1000 + + timeout->tv_usec / 1000); /* do the best we can */ + else + Sleep(UINT_MAX); + return 0; } errno = save_errno; @@ -535,21 +535,21 @@ win32_select(int nfds, Perl_fd_set* rd, Perl_fd_set* wr, Perl_fd_set* ex, const save_errno = errno; for (i = 0; i < nfds; i++) { - if (rd && PERL_FD_ISSET(i,rd)) { - fd = TO_SOCKET(i); - if (!FD_ISSET(fd, &nrd)) - PERL_FD_CLR(i,rd); - } - if (wr && PERL_FD_ISSET(i,wr)) { - fd = TO_SOCKET(i); - if (!FD_ISSET(fd, &nwr)) - PERL_FD_CLR(i,wr); - } - if (ex && PERL_FD_ISSET(i,ex)) { - fd = TO_SOCKET(i); - if (!FD_ISSET(fd, &nex)) - PERL_FD_CLR(i,ex); - } + if (rd && PERL_FD_ISSET(i,rd)) { + fd = TO_SOCKET(i); + if (!FD_ISSET(fd, &nrd)) + PERL_FD_CLR(i,rd); + } + if (wr && PERL_FD_ISSET(i,wr)) { + fd = TO_SOCKET(i); + if (!FD_ISSET(fd, &nwr)) + PERL_FD_CLR(i,wr); + } + if (ex && PERL_FD_ISSET(i,ex)) { + fd = TO_SOCKET(i); + if (!FD_ISSET(fd, &nex)) + PERL_FD_CLR(i,ex); + } } errno = save_errno; return r; @@ -566,7 +566,7 @@ win32_send(SOCKET s, const char *buf, int len, int flags) int win32_sendto(SOCKET s, const char *buf, int len, int flags, - const struct sockaddr *to, int tolen) + const struct sockaddr *to, int tolen) { int r; @@ -623,7 +623,7 @@ open_ifs_socket(int af, int type, int protocol) if (WSCEnumProtocols(NULL, NULL, &proto_buffers_len, &error_code) == SOCKET_ERROR && error_code == WSAENOBUFS) { - WSAPROTOCOL_INFOW *proto_buffers; + WSAPROTOCOL_INFOW *proto_buffers; int protocols_available = 0; Newx(proto_buffers, proto_buffers_len / sizeof(WSAPROTOCOL_INFOW), @@ -672,12 +672,12 @@ win32_socket(int af, int type, int protocol) if((s = open_ifs_socket(af, type, protocol)) == INVALID_SOCKET) { - int wsaerr = WSAGetLastError(); - errno = convert_wsa_error_to_errno(wsaerr); - SetLastError(wsaerr); - } + int wsaerr = WSAGetLastError(); + errno = convert_wsa_error_to_errno(wsaerr); + SetLastError(wsaerr); + } else - s = OPEN_SOCKET(s); + s = OPEN_SOCKET(s); return s; } @@ -693,32 +693,32 @@ int my_close(int fd) { int osf; if (!wsock_started) /* No WinSock? */ - return(close(fd)); /* Then not a socket. */ + return(close(fd)); /* Then not a socket. */ osf = TO_SOCKET(fd);/* Get it now before it's gone! */ if (osf != -1) { - int err; - err = closesocket(osf); - if (err == 0) { + int err; + err = closesocket(osf); + if (err == 0) { #ifdef _set_osfhnd - assert(_osfhnd(fd) == osf); /* catch a bad ioinfo struct def */ - /* don't close freed handle */ - _set_osfhnd(fd, INVALID_HANDLE_VALUE); - return close(fd); + assert(_osfhnd(fd) == osf); /* catch a bad ioinfo struct def */ + /* don't close freed handle */ + _set_osfhnd(fd, INVALID_HANDLE_VALUE); + return close(fd); #else - (void)close(fd); /* handle already closed, ignore error */ - return 0; + (void)close(fd); /* handle already closed, ignore error */ + return 0; #endif - } - else if (err == SOCKET_ERROR) { - int wsaerr = WSAGetLastError(); - err = convert_wsa_error_to_errno(wsaerr); - if (err != ENOTSOCK) { - (void)close(fd); - errno = err; - SetLastError(wsaerr); - return EOF; - } - } + } + else if (err == SOCKET_ERROR) { + int wsaerr = WSAGetLastError(); + err = convert_wsa_error_to_errno(wsaerr); + if (err != ENOTSOCK) { + (void)close(fd); + errno = err; + SetLastError(wsaerr); + return EOF; + } + } } return close(fd); } @@ -729,33 +729,33 @@ my_fclose (FILE *pf) { int osf; if (!wsock_started) /* No WinSock? */ - return(fclose(pf)); /* Then not a socket. */ + return(fclose(pf)); /* Then not a socket. */ osf = TO_SOCKET(win32_fileno(pf));/* Get it now before it's gone! */ if (osf != -1) { - int err; - win32_fflush(pf); - err = closesocket(osf); - if (err == 0) { + int err; + win32_fflush(pf); + err = closesocket(osf); + if (err == 0) { #ifdef _set_osfhnd - assert(_osfhnd(win32_fileno(pf)) == osf); /* catch a bad ioinfo struct def */ - /* don't close freed handle */ - _set_osfhnd(win32_fileno(pf), INVALID_HANDLE_VALUE); - return fclose(pf); + assert(_osfhnd(win32_fileno(pf)) == osf); /* catch a bad ioinfo struct def */ + /* don't close freed handle */ + _set_osfhnd(win32_fileno(pf), INVALID_HANDLE_VALUE); + return fclose(pf); #else - (void)fclose(pf); /* handle already closed, ignore error */ - return 0; + (void)fclose(pf); /* handle already closed, ignore error */ + return 0; #endif - } - else if (err == SOCKET_ERROR) { - int wsaerr = WSAGetLastError(); - err = convert_wsa_error_to_errno(wsaerr); - if (err != ENOTSOCK) { - (void)fclose(pf); - errno = err; - SetLastError(wsaerr); - return EOF; - } - } + } + else if (err == SOCKET_ERROR) { + int wsaerr = WSAGetLastError(); + err = convert_wsa_error_to_errno(wsaerr); + if (err != ENOTSOCK) { + (void)fclose(pf); + errno = err; + SetLastError(wsaerr); + return EOF; + } + } } return fclose(pf); } @@ -814,7 +814,7 @@ win32_getservbyname(const char *name, const char *proto) SOCKET_TEST(r = getservbyname(name, proto), NULL); if (r) { aTHXa(PERL_GET_THX); - r = win32_savecopyservent(&w32_servent, r, proto); + r = win32_savecopyservent(&w32_servent, r, proto); } return r; } @@ -828,7 +828,7 @@ win32_getservbyport(int port, const char *proto) SOCKET_TEST(r = getservbyport(port, proto), NULL); if (r) { aTHXa(PERL_GET_THX); - r = win32_savecopyservent(&w32_servent, r, proto); + r = win32_savecopyservent(&w32_servent, r, proto); } return r; } @@ -840,8 +840,8 @@ win32_ioctl(int i, unsigned int u, char *data) int retval; if (!wsock_started) { - Perl_croak_nocontext("ioctl implemented only on sockets"); - /* NOTREACHED */ + Perl_croak_nocontext("ioctl implemented only on sockets"); + /* NOTREACHED */ } /* mauke says using memcpy avoids alignment issues */ @@ -850,14 +850,14 @@ win32_ioctl(int i, unsigned int u, char *data) memcpy(data, &u_long_arg, sizeof u_long_arg); if (retval == SOCKET_ERROR) { - int wsaerr = WSAGetLastError(); - int err = convert_wsa_error_to_errno(wsaerr); - if (err == ENOTSOCK) { - Perl_croak_nocontext("ioctl implemented only on sockets"); - /* NOTREACHED */ - } - errno = err; - SetLastError(wsaerr); + int wsaerr = WSAGetLastError(); + int err = convert_wsa_error_to_errno(wsaerr); + if (err == ENOTSOCK) { + Perl_croak_nocontext("ioctl implemented only on sockets"); + /* NOTREACHED */ + } + errno = err; + SetLastError(wsaerr); } return retval; } @@ -974,12 +974,12 @@ win32_savecopyservent(struct servent*d, struct servent*s, const char *proto) d->s_aliases = s->s_aliases; d->s_port = s->s_port; if (s->s_proto && strlen(s->s_proto)) - d->s_proto = s->s_proto; + d->s_proto = s->s_proto; else if (proto && strlen(proto)) - d->s_proto = (char *)proto; + d->s_proto = (char *)proto; else - d->s_proto = "tcp"; + d->s_proto = "tcp"; return d; } diff --git a/win32/win32thread.h b/win32/win32thread.h index 9ac964ccf4..9306157c1c 100644 --- a/win32/win32thread.h +++ b/win32/win32thread.h @@ -24,26 +24,26 @@ typedef CRITICAL_SECTION perl_mutex; typedef HANDLE perl_mutex; # define MUTEX_INIT(m) \ STMT_START { \ - if ((*(m) = CreateMutex(NULL,FALSE,NULL)) == NULL) \ - Perl_croak_nocontext("panic: MUTEX_INIT"); \ + if ((*(m) = CreateMutex(NULL,FALSE,NULL)) == NULL) \ + Perl_croak_nocontext("panic: MUTEX_INIT"); \ } STMT_END # define MUTEX_LOCK(m) \ STMT_START { \ - if (WaitForSingleObject(*(m),INFINITE) == WAIT_FAILED) \ - Perl_croak_nocontext("panic: MUTEX_LOCK"); \ + if (WaitForSingleObject(*(m),INFINITE) == WAIT_FAILED) \ + Perl_croak_nocontext("panic: MUTEX_LOCK"); \ } STMT_END # define MUTEX_UNLOCK(m) \ STMT_START { \ - if (ReleaseMutex(*(m)) == 0) \ - Perl_croak_nocontext("panic: MUTEX_UNLOCK"); \ + if (ReleaseMutex(*(m)) == 0) \ + Perl_croak_nocontext("panic: MUTEX_UNLOCK"); \ } STMT_END # define MUTEX_DESTROY(m) \ STMT_START { \ - if (CloseHandle(*(m)) == 0) \ - Perl_croak_nocontext("panic: MUTEX_DESTROY"); \ + if (CloseHandle(*(m)) == 0) \ + Perl_croak_nocontext("panic: MUTEX_DESTROY"); \ } STMT_END #endif @@ -54,53 +54,53 @@ typedef HANDLE perl_mutex; */ #define COND_INIT(c) \ STMT_START { \ - (c)->waiters = 0; \ - (c)->sem = Win_CreateSemaphore(NULL,0,LONG_MAX,NULL); \ - if ((c)->sem == NULL) \ - Perl_croak_nocontext("panic: COND_INIT (%ld)",GetLastError()); \ + (c)->waiters = 0; \ + (c)->sem = Win_CreateSemaphore(NULL,0,LONG_MAX,NULL); \ + if ((c)->sem == NULL) \ + Perl_croak_nocontext("panic: COND_INIT (%ld)",GetLastError()); \ } STMT_END #define COND_SIGNAL(c) \ STMT_START { \ - if ((c)->waiters > 0 && \ - ReleaseSemaphore((c)->sem,1,NULL) == 0) \ - Perl_croak_nocontext("panic: COND_SIGNAL (%ld)",GetLastError()); \ + if ((c)->waiters > 0 && \ + ReleaseSemaphore((c)->sem,1,NULL) == 0) \ + Perl_croak_nocontext("panic: COND_SIGNAL (%ld)",GetLastError()); \ } STMT_END #define COND_BROADCAST(c) \ STMT_START { \ - if ((c)->waiters > 0 && \ - ReleaseSemaphore((c)->sem,(c)->waiters,NULL) == 0) \ - Perl_croak_nocontext("panic: COND_BROADCAST (%ld)",GetLastError());\ + if ((c)->waiters > 0 && \ + ReleaseSemaphore((c)->sem,(c)->waiters,NULL) == 0) \ + Perl_croak_nocontext("panic: COND_BROADCAST (%ld)",GetLastError());\ } STMT_END #define COND_WAIT(c, m) \ STMT_START { \ - (c)->waiters++; \ - MUTEX_UNLOCK(m); \ - /* Note that there's no race here, since a \ - * COND_BROADCAST() on another thread will have seen the\ - * right number of waiters (i.e. including this one) */ \ - if (WaitForSingleObject((c)->sem,INFINITE)==WAIT_FAILED)\ - Perl_croak_nocontext("panic: COND_WAIT (%ld)",GetLastError()); \ - /* XXX there may be an inconsequential race here */ \ - MUTEX_LOCK(m); \ - (c)->waiters--; \ + (c)->waiters++; \ + MUTEX_UNLOCK(m); \ + /* Note that there's no race here, since a \ + * COND_BROADCAST() on another thread will have seen the\ + * right number of waiters (i.e. including this one) */ \ + if (WaitForSingleObject((c)->sem,INFINITE)==WAIT_FAILED)\ + Perl_croak_nocontext("panic: COND_WAIT (%ld)",GetLastError()); \ + /* XXX there may be an inconsequential race here */ \ + MUTEX_LOCK(m); \ + (c)->waiters--; \ } STMT_END #define COND_DESTROY(c) \ STMT_START { \ - (c)->waiters = 0; \ - if (CloseHandle((c)->sem) == 0) \ - Perl_croak_nocontext("panic: COND_DESTROY (%ld)",GetLastError()); \ + (c)->waiters = 0; \ + if (CloseHandle((c)->sem) == 0) \ + Perl_croak_nocontext("panic: COND_DESTROY (%ld)",GetLastError()); \ } STMT_END #define DETACH(t) \ STMT_START { \ - if (CloseHandle((t)->self) == 0) { \ - MUTEX_UNLOCK(&(t)->mutex); \ - Perl_croak_nocontext("panic: DETACH"); \ - } \ + if (CloseHandle((t)->self) == 0) { \ + MUTEX_UNLOCK(&(t)->mutex); \ + Perl_croak_nocontext("panic: DETACH"); \ + } \ } STMT_END @@ -148,15 +148,15 @@ END_EXTERN_C #define INIT_THREADS NOOP #define ALLOC_THREAD_KEY \ STMT_START { \ - if ((PL_thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) { \ - PerlIO_printf(PerlIO_stderr(),"panic: TlsAlloc"); \ - exit(1); \ - } \ + if ((PL_thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) { \ + PerlIO_printf(PerlIO_stderr(),"panic: TlsAlloc"); \ + exit(1); \ + } \ } STMT_END #define FREE_THREAD_KEY \ STMT_START { \ - TlsFree(PL_thr_key); \ + TlsFree(PL_thr_key); \ } STMT_END #define PTHREAD_ATFORK(prepare,parent,child) NOOP @@ -164,19 +164,19 @@ END_EXTERN_C #if defined(USE_RTL_THREAD_API) && !defined(_MSC_VER) #define JOIN(t, avp) \ STMT_START { \ - if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \ - || (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \ - || (CloseHandle((t)->self) == 0)) \ - Perl_croak_nocontext("panic: JOIN"); \ - *avp = (AV *)((t)->i.retv); \ + if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \ + || (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \ + || (CloseHandle((t)->self) == 0)) \ + Perl_croak_nocontext("panic: JOIN"); \ + *avp = (AV *)((t)->i.retv); \ } STMT_END #else /* !USE_RTL_THREAD_API || _MSC_VER */ #define JOIN(t, avp) \ STMT_START { \ - if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \ - || (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \ - || (CloseHandle((t)->self) == 0)) \ - Perl_croak_nocontext("panic: JOIN"); \ + if ((WaitForSingleObject((t)->self,INFINITE) == WAIT_FAILED) \ + || (GetExitCodeThread((t)->self,(LPDWORD)(avp)) == 0) \ + || (CloseHandle((t)->self) == 0)) \ + Perl_croak_nocontext("panic: JOIN"); \ } STMT_END #endif /* !USE_RTL_THREAD_API || _MSC_VER */ |